AROP + Gini

AROP

AROP:
- ✅ vzít ekvivalizované příjmy domácností
- ✅ přepočítat je na příjmy v PPP/PPS (srovnatelnou currency z hlediska, co si za ní koupíš)
- ✅ spočítat 60 % evropského mediánu
- ✅ spočítat, kolik domácností v různých zemí je pod
- ✅ jak se to liší od běžné AROP národní
- ✅ focus na ČR - jak se české a evropské AROP liší v různých typech domácností
- nice to haves:
- jak se tím změní AROPE - ukazatel, který zahrnuje AROP OR těžká materiální deprivace OR dlouhodobá nezaměstnanost, a v poslední dobe je používanější a vytvuří zdání robustnosti, ale je destruován tím AROP
- ✅ jak se změní vývoj v čase - zvětšuje se evropská chudoba v ČR (např. proti roku 2018, 2019)

Power Purchasing Parity je odsud.

V SILCu jsou příjmy domácností v eurech, pro země, které nepřijaly euro, je potřeba převést příjmy do národní měny. Měnové kurzy jsou odsud.

library(gt)
library(DT)
library(paqr)
library(dplyr)
library(corrr)
library(Hmisc)
library(haven)
library(readxl)
library(eulerr)
library(ggtext)
library(targets)
library(ggplot2)
library(ggrepel)
library(ggridges)
library(DescTools)
library(patchwork)

tar_load(r_silc_2023)

hh_r_silc_2023 <- r_silc_2023 %>% 
  group_by(country, hh_id) %>% 
  mutate(
    n_retired = sum(econ_status == "Retired", na.rm = TRUE), 
    n_employed = sum(econ_status == "Employed", na.rm = TRUE), 
    n_adults = sum(age >= 18), 
    n_old_age = sum(age >= 65),
    income_disposable = if_else(income_disposable < 0, 0, income_disposable),  
    income_disposable_eqi = if_else(income_disposable_eqi < 0, 0, income_disposable_eqi)
  ) %>% 
  slice(1) %>% 
  ungroup() %>% 
  mutate(across(where(is.character), ~haven::as_factor(.x))) %>% 
  # filter out EU countries only
  filter(country != "Norway") %>% 
  mutate(
    country = fct_case_when(
      country == "Oesterreich" ~ "Austria",
      country == "Belgique" ~ "Belgium",
      country == "Deutschland" ~ "Germany",
      country == "Danmark" ~ "Denmark",
      country == "Ellada" ~ "Greece",
      country == "Espana" ~ "Spain",
      country == "Suomi" ~ "Finland",
      country == "Nederland" ~ "Netherlands",
      country == "Sverige" ~ "Sweden", 
      country == "Italia" ~ "Italy",
      country == "Czech Republic" ~ "Czechia",
      country == "Slovak Republic" ~ "Slovakia",
      TRUE ~ country
    ), 
    r_tenure_status = fct_case_when(
      grepl("Tenant", tenure_status) ~ "Tenant", 
      grepl("Owner", tenure_status) ~ "Owner"
    )
  ) %>% 
  mutate(
    hh_retired = fct_case_when(
      n_retired == n_persons ~ "Plně důchodcovská domácnost", 
      n_retired > 0 ~ "Domácnost s důchodcem",
      n_retired == 0 ~ "Domácnost bez důchodců"
    ), 
    hh_old = fct_case_when(
      n_old_age == n_persons ~ "Všichni 65+",
      n_old_age > 0 ~ "Alespoň jeden 65+",
      n_old_age == 0 ~ "Bez 65+"
    ),
    typ_domacnosti = fct_case_when(
      n_adults == 2 & n_children > 0 ~ "Úplná domácnost s dětmi",
      n_adults == 1 & n_children > 0 ~ "Samoživitel/ka s dětmi",
      n_adults == 2 & hh_retired == "Plně důchodcovská domácnost" ~ "Dvojice seniorů",
      n_adults == 1 & hh_retired == "Plně důchodcovská domácnost" ~ "Samostatně žijící senior",
      TRUE ~ "Ostatní"
    )
  )

regiony <- hh_r_silc_2023 %>% 
  filter(region != "info not provided for DE, NL, PT, RS") %>% 
  group_by(country, region) %>% 
  summarise(mean_income = mean(income_disposable_eqi)) %>% 
  group_by(country) %>% 
  filter(mean_income == max(mean_income) | mean_income == min(mean_income)) %>% 
  mutate(
    n = n(), 
    region_typ = case_when(
      mean_income == max(mean_income) ~ "nejbohatší region", 
      mean_income == min(mean_income) ~ "nejchudší region"
    )
  ) %>% 
  filter(n == 2) %>% 
  ungroup %>% 
  select(country, region, region_typ)
  
exchange_rates <- read_excel("data/exchange_rates.xlsx", sheet = 3, skip = 8) %>% 
  select(currency = TIME, exchange_rate_2022 = `2022`) %>% 
  filter(!is.na(currency)) %>% 
  mutate(country = case_when(
    currency == "Bulgarian lev" ~ "Bulgaria",
    currency == "Czech koruna" ~ "Czechia",
    currency == "Danish krone" ~ "Denmark",
    currency == "Hungarian forint" ~ "Hungary",
    currency == "Polish zloty" ~ "Poland",
    currency == "Romanian leu" ~ "Romania",
    currency == "Swedish krona" ~ "Sweden"
  )) %>% 
  filter(!is.na(country)) %>% 
  mutate(exchange_rate_2022 = as.numeric(exchange_rate_2022))

ppp_data <- read_excel("data/power_purchasing_parity_2decimals.xlsx") %>% 
  select(country = Country, ppp_2022 = `2022`)

ppp_adjusted <- left_join(ppp_data, exchange_rates, by = "country") %>% 
  mutate(ppp_2022_adjusted = if_else(
    !is.na(exchange_rate_2022), 
    ppp_2022 / exchange_rate_2022,
    ppp_2022
  )) %>% 
  select(country, ppp_2022_adjusted) 

hh_r_silc_2023_ppp <- left_join(hh_r_silc_2023, ppp_adjusted, by = "country") %>% 
  mutate(
    income_disposable_eqi_ppp = income_disposable_eqi / ppp_2022_adjusted
  ) %>% 
  left_join(., regiony, by = c("country", "region"))

EU_MEDIAN_PPP <- wtd.quantile(hh_r_silc_2023_ppp$income_disposable_eqi_ppp,
                              hh_r_silc_2023_ppp$hh_cross_weight, 0.5)  
EU_MEDIAN_60PCT <- EU_MEDIAN_PPP * 0.6
EU_MEDIAN_50PCT <- EU_MEDIAN_PPP * 0.5
EU_MEDIAN_70PCT <- EU_MEDIAN_PPP * 0.7

hh_r_silc_2023_arop <- hh_r_silc_2023_ppp %>% 
  mutate(
    under_arop = income_disposable_eqi_ppp < EU_MEDIAN_60PCT, 
    under_eu_poverty = income_disposable_eqi_ppp < EU_MEDIAN_50PCT, 
    under_eu_70_boundary = income_disposable_eqi_ppp < EU_MEDIAN_70PCT, 
    r_country = if_else(country == "Czechia", "Česko", "zbytek EU")
  )

eu_arop_2023b <- hh_r_silc_2023_arop %>% 
  group_by(r_country) %>% 
  summarise(
    pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100, 
    pct_under_eu_poverty = wtd.mean(under_eu_poverty, hh_cross_weight, na.rm = TRUE) * 100  
  )

eu_arop_2023b %>% 
  arrange(pct_under_arop) %>% 
  knitr::kable(., digits = 2, col.names = c("Country", "% under EU AROP", "% under 50% of EU median"))

Country	% under EU AROP	% under 50% of EU median
zbytek EU	19.25	12.82
Česko	21.68	10.35

eu_arop_2023 <- hh_r_silc_2023_arop %>% 
  group_by(country) %>% 
  summarise(
    pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100, 
    pct_under_eu_poverty = wtd.mean(under_eu_poverty, hh_cross_weight, na.rm = TRUE) * 100)

eu_arop_2023 %>% 
  arrange(pct_under_arop) %>% 
  knitr::kable(., digits = 2, col.names = c("Country", "% under EU AROP", "% under 50% of EU median"))

Country	% under EU AROP	% under 50% of EU median
Luxembourg	3.12	2.38
Belgium	3.96	2.10
Ireland	4.73	2.40
Austria	6.43	4.10
Denmark	7.45	4.35
Netherlands	7.49	4.98
Finland	10.35	4.93
Germany	10.84	6.51
France	11.14	6.61
Cyprus	13.87	5.85
Slovenia	14.79	7.12
Sweden	15.21	9.71
Malta	17.39	9.63
Italy	17.92	11.75
Spain	20.14	12.79
Czechia	21.68	10.35
Poland	26.87	16.66
Portugal	37.70	25.59
Estonia	39.24	30.21
Lithuania	41.26	30.83
Croatia	42.35	31.80
Latvia	46.01	37.06
Greece	48.06	34.05
Slovakia	51.33	30.90
Romania	51.73	38.96
Hungary	55.85	42.35
Bulgaria	59.87	49.22

hh_r_silc_2023_arop |> 
  summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100)

## # A tibble: 1 × 1
##   pct_under_arop
##            <dbl>
## 1           19.3

Srovnání EU vs. národní AROP

national_medians <- hh_r_silc_2023_ppp %>% 
  group_by(country) %>% 
  summarise(median_income = wtd.quantile(income_disposable_eqi_ppp, 
                                         hh_cross_weight, 0.5), 
            .groups = "drop") %>% 
  mutate(
    national_70_boundary = median_income * 0.7,
    national_arop_boundary = median_income * 0.6, 
    national_poverty_boundary = median_income * 0.5
  )

hh_r_silc_2023_national_arop <- full_join(hh_r_silc_2023_arop, national_medians, 
                                          by = "country") %>% 
  mutate(
    under_70_boundary = income_disposable_eqi_ppp < national_70_boundary,
    under_national_arop = income_disposable_eqi_ppp < national_arop_boundary,
    under_national_poverty = income_disposable_eqi_ppp < national_poverty_boundary, 
    r_country = if_else(country == "Czechia", "Czechia", "Rest of EU")
  )
  
eu_national_arop <- hh_r_silc_2023_national_arop %>% 
  group_by(r_country) %>% 
  summarise(pct_under_national_arop = wtd.mean(
    under_national_arop, hh_cross_weight, na.rm = TRUE) * 100) %>% 
  left_join(eu_arop_2023b, ., by = "r_country")

eu_national_arop %>% 
  arrange(pct_under_national_arop) %>% 
  knitr::kable(., digits = 2, col.names = c("Country", "% under EU AROP", "% under 50% of EU median",
                                            "% under national AROP"))

Country	% under EU AROP	% under 50% of EU median	% under national AROP
zbytek EU	19.25	12.82	NA
Česko	21.68	10.35	NA

eu_national_arop <- hh_r_silc_2023_national_arop %>% 
  group_by(country) %>% 
  summarise(pct_under_national_arop = wtd.mean(
    under_national_arop, hh_cross_weight, na.rm = TRUE) * 100) %>% 
  left_join(eu_arop_2023, ., by = "country")

eu_national_arop %>% 
  arrange(pct_under_national_arop) %>% 
  knitr::kable(., digits = 2, col.names = c("Country", "% under EU AROP", "% under 50% of EU median",
                                            "% under national AROP"))

Country	% under EU AROP	% under 50% of EU median	% under national AROP
Czechia	21.68	10.35	9.80
Belgium	3.96	2.10	10.20
Finland	10.35	4.93	12.69
Hungary	55.85	42.35	12.80
Denmark	7.45	4.35	12.83
Slovakia	51.33	30.90	13.29
Netherlands	7.49	4.98	14.56
Ireland	4.73	2.40	14.82
France	11.14	6.61	14.87
Cyprus	13.87	5.85	15.04
Slovenia	14.79	7.12	15.06
Poland	26.87	16.66	15.24
Austria	6.43	4.10	15.49
Germany	10.84	6.51	15.59
Bulgaria	59.87	49.22	16.24
Sweden	15.21	9.71	16.31
Portugal	37.70	25.59	17.47
Luxembourg	3.12	2.38	18.18
Greece	48.06	34.05	18.58
Italy	17.92	11.75	19.23
Romania	51.73	38.96	19.40
Malta	17.39	9.63	19.40
Spain	20.14	12.79	20.19
Lithuania	41.26	30.83	21.92
Croatia	42.35	31.80	22.30
Latvia	46.01	37.06	24.52
Estonia	39.24	30.21	25.58

ggplot(eu_national_arop, aes(x = pct_under_national_arop, y = pct_under_arop)) + 
  geom_point() + 
  geom_text_repel(aes(label = country)) + 
  scale_y_continuous(labels = scales::label_percent(scale = 1)) + 
  scale_x_continuous(labels = scales::label_percent(scale = 1)) + 
  geom_smooth(se = FALSE, method = "lm") +
  theme_paq() + 
  labs(x = "% under (national) AROP", y = "% under EU AROP") 

country_median_income_ppp <- hh_r_silc_2023_national_arop %>% 
  group_by(country) %>% 
  summarise(median_income_ppp = median(income_disposable_eqi_ppp)) %>% 
  arrange(desc(median_income_ppp))

hh_r_silc_2023_national_arop %>% 
  ggplot(aes(x = factor(country, levels = rev(country_median_income_ppp$country)), 
             y = income_disposable_eqi_ppp)) + 
  geom_boxplot(outliers = FALSE) + 
  geom_point(data = national_medians, aes(x = country, y = national_arop_boundary), 
             colour = "blue", shape = 3) + 
  geom_hline(yintercept = EU_MEDIAN_60PCT, colour = "red") + 
  theme_paq() + 
  coord_flip() + 
  labs(x = "", y = "Disponibilní ekvivalizovaný příjem domácnosti v PPS", 
       caption = "Modrý kříž indikuje národní hranici chudoby (60 % národního mediánu)")

chart_data <- hh_r_silc_2023_national_arop %>% 
  group_by(country) %>%
  summarise(q90 = wtd.quantile(income_disposable_eqi_ppp, hh_cross_weight, 0.90), 
            q10 = wtd.quantile(income_disposable_eqi_ppp, hh_cross_weight, 0.10)) %>%
  ungroup %>% 
  left_join(., national_medians, by = "country") %>% 
  mutate(country = factor(country, levels = rev(country_median_income_ppp$country)))

chart_data %>% 
  ggplot() + 
  geom_rect(aes(xmin = as.numeric(country) - 0.4, 
                xmax = as.numeric(country) + 0.4, 
                ymin = q10, ymax = q90), 
            alpha = 0.5) +
  scale_x_continuous(
    breaks = 1:nlevels(chart_data$country),
    labels = levels(chart_data$country)
  ) +
  scale_y_continuous(limits = c(0, NA)) + 
  geom_rect(aes(xmin = as.numeric(country) - 0.4, 
                     xmax = as.numeric(country) + 0.4,
                     ymin = national_arop_boundary,
                     ymax = national_arop_boundary), 
                 colour = "blue") + 
  geom_hline(yintercept = EU_MEDIAN_60PCT, colour = "red") +
  coord_flip() + 
  theme_paq() + 
  labs(x = "", y = "Disponibilní ekvivalizovaný příjem domácnosti v PPS")

chart_data <- hh_r_silc_2023_national_arop %>% 
  group_by(country) %>%
  summarise(q50 = wtd.quantile(income_disposable_eqi_ppp, hh_cross_weight, 0.50), 
            q01 = wtd.quantile(income_disposable_eqi_ppp, hh_cross_weight, 0.01)) %>%
  ungroup %>% 
  left_join(., national_medians, by = "country") %>% 
  mutate(country = factor(country, levels = rev(country_median_income_ppp$country)))

chart_data %>% 
  ggplot() + 
  geom_rect(aes(xmin = as.numeric(country) - 0.4, 
                xmax = as.numeric(country) + 0.4, 
                ymin = q01, ymax = q50), 
            alpha = 0.5) +
  scale_x_continuous(
    breaks = 1:nlevels(chart_data$country),
    labels = levels(chart_data$country)
  ) +
  geom_rect(aes(xmin = as.numeric(country) - 0.4, 
                     xmax = as.numeric(country) + 0.4,
                     ymin = national_arop_boundary,
                     ymax = national_arop_boundary), 
                 colour = "blue") + 
  geom_hline(yintercept = EU_MEDIAN_60PCT, colour = "red") +
  coord_flip() + 
  theme_paq() + 
  labs(x = "", y = "Disponibilní ekvivalizovaný příjem domácnosti v PPS")

chart_data_1_99 <- hh_r_silc_2023_national_arop %>% 
  group_by(country) %>%
  summarise(q99 = wtd.quantile(income_disposable_eqi_ppp, hh_cross_weight, 0.99), 
            q01 = wtd.quantile(income_disposable_eqi_ppp, hh_cross_weight, 0.01)) %>%
  ungroup %>% 
  left_join(., national_medians, by = "country") %>% 
  mutate(country = factor(country, levels = rev(country_median_income_ppp$country)))

chart_data_1_99 %>% 
  ggplot() + 
  geom_rect(aes(xmin = as.numeric(country) - 0.4, 
                xmax = as.numeric(country) + 0.4, 
                ymin = q01, ymax = q99), 
            alpha = 0.5) +
  scale_x_continuous(
    breaks = 1:nlevels(chart_data$country),
    labels = levels(chart_data$country)
  ) +
  geom_rect(aes(xmin = as.numeric(country) - 0.4, 
                     xmax = as.numeric(country) + 0.4,
                     ymin = national_arop_boundary,
                     ymax = national_arop_boundary), 
                 colour = "blue") + 
  geom_hline(yintercept = EU_MEDIAN_60PCT, colour = "red") +
  coord_flip() + 
  theme_paq() + 
  labs(x = "", y = "Disponibilní ekvivalizovaný příjem domácnosti v PPS")

hh_r_silc_2023_national_arop %>% 
  filter(country == "Czechia") %>% 
  pull (income_disposable_eqi_ppp) %>% 
  density() -> m_dens

country_q95 <- hh_r_silc_2023_national_arop %>% 
  group_by(country) %>% 
  summarise(q95 = wtd.quantile(income_disposable_eqi_ppp, hh_cross_weight, 0.95))

countries <- unique(hh_r_silc_2023_national_arop$country)
density_df <- purrr::map_df(countries, function(x) {
  country <- x
  tmp <- hh_r_silc_2023_national_arop %>% 
    filter(country == x)
  
  national_arop_boundary <- unique(tmp$national_arop_boundary)
  
  dens <- density(tmp$income_disposable_eqi_ppp, n = 50000)
  
  tibble(
    x = dens$x, 
    y = dens$y, 
    under_national_arop = x < national_arop_boundary, 
    country = country
  )
})

CZ_MEDIAN_60PCT <- national_medians |> 
  filter(country == "Czechia") |> 
  pull(national_arop_boundary)

density_df %>% 
  left_join(., country_q95, by = "country") %>% 
  filter(x <= q95) %>% 
  mutate(
    country = fct_case_when(
      country == "Bulgaria" ~ "Bulharsko",
      country == "Hungary" ~ "Maďarsko",
      country == "Slovakia" ~ "Slovensko",
      country == "Greece" ~ "Řecko",
      country == "Romania" ~ "Rumunsko",
      country == "Croatia" ~ "Chorvatsko",
      country == "Latvia" ~ "Lotyšsko",
      country == "Lithuania" ~ "Litva",
      country == "Portugal" ~ "Portugalsko",
      country == "Estonia" ~ "Estonsko",
      country == "Poland" ~ "Polsko",
      country == "Czechia" ~ "Česko",
      country == "Malta" ~ "Malta",
      country == "Cyprus" ~ "Kypr",
      country == "Spain" ~ "Španělsko",
      country == "Slovenia" ~ "Slovinsko",
      country == "Italy" ~ "Itálie",
      country == "France" ~ "Francie",
      country == "Germany" ~ "Německo",
      country == "Sweden" ~ "Švédsko",
      country == "Denmark" ~ "Dánsko",
      country == "Belgium" ~ "Belgie",
      country == "Netherlands" ~ "Nizozemsko",
      country == "Finland" ~ "Finsko",
      country == "Ireland" ~ "Irsko",
      country == "Austria" ~ "Rakousko",
      country == "Luxembourg" ~ "Lucembursko"
    ), 
    under_national_arop = factor(under_national_arop, 
                                 levels = c(TRUE, FALSE), 
                                 labels = c("Pod 60 % mediánu národního příjmu", 
                                            "Nad 60 % mediánu"))
  ) %>% 
  ggplot(., aes(x = x, y = country,
                height = y * 10000, fill = under_national_arop)) + 
  # geom_vline(xintercept = EU_MEDIAN_60PCT, colour = "red") + 
  # geom_vline(xintercept = EU_MEDIAN_50PCT, colour = "darkred") + 
  # geom_vline(xintercept = CZ_MEDIAN_60PCT, colour = "blue") + 
  geom_ridgeline_gradient() + 
  scale_x_continuous(limits = c(0, 75000), labels = scales::comma_format(big.mark = " ")) + 
  scale_fill_manual(values = c("Pod 60 % mediánu národního příjmu" = "#ECB925", 
                               "Nad 60 % mediánu" = "gray80")) + 
  theme_paq() + 
  # theme(legend.position = "none") + 
  labs(x = "Ekvivalizovaný příjem domácnosti ve standardu kupní síly", y = ""
      #  caption = "Distribuce nezobrazují hodnoty nad 95. percentil v daném státu. Modrá svislice ukazuje českou hranici chudoby,\ntmavě červená 50 % evropského mediánu, červená evropskou hranici chudoby (60 % mediánu)."
       )

save_plot(plot = last_plot(),
          path = "figs/arop/arop1.png", 
          height_px = 600, 
          width_px = 600)

Kolik by bylo v evropských státech pod českou hranicí chudoby

hh_r_silc_2023_national_arop |> 
  group_by(country) |> 
  mutate(under_cz_arop = income_disposable_eqi_ppp < CZ_MEDIAN_60PCT) |> 
  summarise(under_cz_arop = wtd.mean(under_cz_arop, hh_cross_weight, na.rm = TRUE) * 100) |> 
  arrange(under_cz_arop) |> 
  knitr::kable(col.names = c("Country", "% under CZ poverty line"))

Country	% under CZ poverty line
Belgium	2.045642
Ireland	2.254960
Luxembourg	2.377036
Austria	4.031356
Denmark	4.149577
Finland	4.593589
Netherlands	4.946518
Cyprus	5.458738
Germany	6.268019
France	6.385330
Slovenia	6.921078
Malta	9.326997
Sweden	9.475918
Czechia	9.803617
Italy	11.274460
Spain	12.459903
Poland	16.022737
Portugal	24.701623
Slovakia	29.314007
Estonia	29.366123
Lithuania	30.124821
Croatia	31.054021
Greece	32.842150
Latvia	36.504372
Romania	37.551559
Hungary	41.150338
Bulgaria	48.173245

Jak moc to souvisí s materiální a sociální deprivací

AROPE (Ohrožení chudobou nebo sociálním vyloučením)

AROPE = (AROP | nízká pracovní intenzita | vážná materiální nebo sociální deprivace)

• vážná materiální a sociální deprivace = alespoň 7 ze 13 položek týkající se deprivace (6 ohledně jednotlivce, 7 za domácnost)
• AROP
• velmi nízká pracovní intenzita (pro domácnosti tvořené dospělými ve věku 18-64) = dospělí pracovovali méně než 20% jejich pracovního potenciálu

hh_r_silc_2023_national_arop %>% 
  group_by(country) %>% 
  summarise(
    severely_deprived = wtd.mean(severe_material_social_deprivation, hh_cross_weight)
  )

## # A tibble: 27 × 2
##    country  severely_deprived
##    <chr>                <dbl>
##  1 Austria             0.0407
##  2 Belgium             0.0703
##  3 Bulgaria            0.192 
##  4 Croatia             0.0422
##  5 Cyprus              0.0299
##  6 Czechia             0.0283
##  7 Denmark             0.0600
##  8 Estonia             0.0277
##  9 Finland             0.0385
## 10 France              0.0713
## # ℹ 17 more rows

hh_r_silc_2023_national_arop %>% 
  filter(low_work_intensity != 2) %>% 
  group_by(country) %>% 
  summarise(
    low_work_intensity = wtd.mean(low_work_intensity, hh_cross_weight)
  )

## # A tibble: 27 × 2
##    country  low_work_intensity
##    <chr>                 <dbl>
##  1 Austria              0.0752
##  2 Belgium              0.139 
##  3 Bulgaria             0.0757
##  4 Croatia              0.0506
##  5 Cyprus               0.0533
##  6 Czechia              0.0553
##  7 Denmark              0.150 
##  8 Estonia              0.0786
##  9 Finland              0.124 
## 10 France               0.104 
## # ℹ 17 more rows

hh_r_silc_2023_national_arop %>% 
  mutate(arope = under_national_arop | 
           low_work_intensity == 1 | 
           severe_material_social_deprivation == 1) %>% 
  group_by(country) %>% 
  summarise(
    pct_arope = wtd.mean(arope, hh_cross_weight), 
    pct_national_arop = wtd.mean(under_national_arop, hh_cross_weight)
  ) %>% 
  ggplot(., aes(x = pct_arope, y = pct_national_arop)) + 
  # geom_abline(slope = 1, colour = "black") + 
  geom_smooth(method = "lm", se = FALSE, colour = "gray80") + 
  geom_text_repel(aes(label = country)) + 
  geom_point() + 
  scale_x_continuous(labels = scales::label_percent(suffix = " %")) +
  scale_y_continuous(labels = scales::label_percent(suffix = " %")) + 
  theme_paq() + 
  coord_equal() + 
  labs(x = "Podíl domácností v ohrožení chudobou a sociálním vyloučením", 
       y = "Podíl domácností v ohrožení chudobou")

hh_r_silc_2023_national_arop |> 
  ggplot(aes(x = sum_deprived_items)) + 
  geom_histogram(aes(y = ..density..), bins = 14) + 
  facet_wrap(~country) + 
  theme_paq()

aropes <- hh_r_silc_2023_national_arop %>% 
  mutate(arope = under_national_arop | 
           low_work_intensity == 1 | 
           severe_material_social_deprivation == 1, 
         eu_arope = under_eu_poverty | 
           low_work_intensity == 1 | 
           severe_material_social_deprivation == 1) %>% 
  group_by(country) %>% 
  summarise(
    pct_eu_arope = wtd.mean(eu_arope, hh_cross_weight), 
    pct_national_arope = wtd.mean(arope, hh_cross_weight)
  ) %>% 
  mutate(
    country = fct_case_when(
      country == "Bulgaria" ~ "Bulharsko",
      country == "Hungary" ~ "Maďarsko",
      country == "Slovakia" ~ "Slovensko",
      country == "Greece" ~ "Řecko",
      country == "Romania" ~ "Rumunsko",
      country == "Croatia" ~ "Chorvatsko",
      country == "Latvia" ~ "Lotyšsko",
      country == "Lithuania" ~ "Litva",
      country == "Portugal" ~ "Portugalsko",
      country == "Estonia" ~ "Estonsko",
      country == "Poland" ~ "Polsko",
      country == "Czechia" ~ "Česko",
      country == "Malta" ~ "Malta",
      country == "Cyprus" ~ "Kypr",
      country == "Spain" ~ "Španělsko",
      country == "Slovenia" ~ "Slovinsko",
      country == "Italy" ~ "Itálie",
      country == "France" ~ "Francie",
      country == "Germany" ~ "Německo",
      country == "Sweden" ~ "Švédsko",
      country == "Denmark" ~ "Dánsko",
      country == "Belgium" ~ "Belgie",
      country == "Netherlands" ~ "Nizozemsko",
      country == "Finland" ~ "Finsko",
      country == "Ireland" ~ "Irsko",
      country == "Austria" ~ "Rakousko",
      country == "Luxembourg" ~ "Lucembursko"
    )
  ) 

aropes %>% 
  ggplot(., aes(x = pct_eu_arope, y = pct_national_arope)) + 
  geom_smooth(method = "lm", se = FALSE, colour = "gray80") + 
  geom_text_repel(aes(label = country)) + 
  geom_point() + 
  scale_x_continuous(labels = scales::label_percent(suffix = " %")) +
  scale_y_continuous(labels = scales::label_percent(suffix = " %")) + 
  theme_paq() + 
  coord_equal() + 
  labs(x = "Podíl domácností v ohrožení EU chudobou (50 % evropského mediánu) a sociálním vyloučením", 
       y = "Podíl domácností v ohrožení národní chudobou (60 % národního mediánu) a sociálním vyloučením")

cntry_levels <- aropes |> arrange(pct_eu_arope) |> pull(country)
aropes %>% 
  tidyr::pivot_longer(cols = c(pct_eu_arope, pct_national_arope)) %>% 
  mutate(name = case_when(
    name == "pct_eu_arope" ~ "Podíl domácností v ohrožení EU chudobou (50 % evropského mediánu) a sociálním vyloučením", 
    name == "pct_national_arope" ~ "Podíl domácností v ohrožení národní chudobou (60 % národního mediánu) a sociálním vyloučením"
  ), 
    country = factor(country, levels = rev(cntry_levels))
  ) %>% 
  ggplot(., aes(x = country, y = value, fill = name)) + 
  geom_bar(stat = "identity", position = "dodge") + 
  scale_y_continuous(labels = scales::label_percent(suffix = " %")) + 
  coord_flip() + 
  theme_paq() + 
  guides(fill = guide_legend(nrow = 2)) + 
  scale_fill_manual(values = paleta_kategoricka(2)) + 
  labs(x = "", y = "")

save_plot(plot = last_plot(),
          path = "figs/arop/aropes.png", 
          height_px = 600, 
          width_px = 600)

Za kolik z AROPE může AROP, deprivace, nízká pracovní aktivita

AROPE s národní hranicí

national_arope_data <- hh_r_silc_2023_national_arop |> 
  mutate(type = fct_case_when(
    under_national_arop ~ "Pod národní hranicí chudoby",
    severe_material_social_deprivation == 1 ~ "Vážně materiálně či sociálně deprivovaný",
    low_work_intensity == 1 ~ "Nízká pracovní intenzita", 
    TRUE ~ "není v AROPE", 
    new_levels = c("není v AROPE", "Nízká pracovní intenzita", "Vážně materiálně či sociálně deprivovaný", "Pod národní hranicí chudoby")
  ), 
    country = fct_case_when(
      country == "Bulgaria" ~ "Bulharsko",
      country == "Hungary" ~ "Maďarsko",
      country == "Slovakia" ~ "Slovensko",
      country == "Greece" ~ "Řecko",
      country == "Romania" ~ "Rumunsko",
      country == "Croatia" ~ "Chorvatsko",
      country == "Latvia" ~ "Lotyšsko",
      country == "Lithuania" ~ "Litva",
      country == "Portugal" ~ "Portugalsko",
      country == "Estonia" ~ "Estonsko",
      country == "Poland" ~ "Polsko",
      country == "Czechia" ~ "Česko",
      country == "Malta" ~ "Malta",
      country == "Cyprus" ~ "Kypr",
      country == "Spain" ~ "Španělsko",
      country == "Slovenia" ~ "Slovinsko",
      country == "Italy" ~ "Itálie",
      country == "France" ~ "Francie",
      country == "Germany" ~ "Německo",
      country == "Sweden" ~ "Švédsko",
      country == "Denmark" ~ "Dánsko",
      country == "Belgium" ~ "Belgie",
      country == "Netherlands" ~ "Nizozemsko",
      country == "Finland" ~ "Finsko",
      country == "Ireland" ~ "Irsko",
      country == "Austria" ~ "Rakousko",
      country == "Luxembourg" ~ "Lucembursko"
    )
  )

eu_arope_split <- national_arope_data |> 
  group_by(type) |> 
  summarise(n = sum(hh_cross_weight)) |> 
  ungroup() |> 
  mutate(pct = n / sum(n), 
         country = "EU")

arope_split <- national_arope_data |> 
  group_by(country, type) |> 
  summarise(n = sum(hh_cross_weight)) |> 
  group_by(country) |> 
  mutate(pct = n / sum(n))

arope_split_countries <- arope_split |> 
  filter(type == "není v AROPE") |> 
  arrange(desc(pct)) |> 
  pull(country)

arope_split |> 
  filter(type != "není v AROPE") |> 
  mutate(country = factor(country, levels = arope_split_countries)) |> 
  ggplot(aes(x = country, y = pct, fill = type)) + 
  geom_bar(stat = "identity") + 
  theme_paq() + 
  scale_y_continuous(labels = scales::label_percent(suffix = " %"), expand = c(0, 0)) +
  scale_fill_manual(values = paleta_kategoricka(3)) +
  coord_flip() +
  labs(x = "", y = "% domácností") + 
  guides(fill = guide_legend(nrow = 3, reverse = TRUE)) + 
  theme(panel.grid.major.y = element_blank())

save_plot(last_plot(), "figs/arop/arop_composition.png")

arope_split |> 
  bind_rows(eu_arope_split) |> 
  filter(type != "není v AROPE") |> 
  mutate(country = factor(country, levels = c(as.character(arope_split_countries), "EU"))) |> 
  ggplot(aes(x = country, y = pct, fill = type)) + 
  geom_bar(stat = "identity") + 
  theme_paq() + 
  scale_y_continuous(labels = scales::label_percent(suffix = " %"), expand = c(0, 0)) +
  scale_fill_manual(values = rev(paleta_kategoricka(3))) +
  coord_flip() +
  labs(x = "", y = "% domácností") + 
  guides(fill = guide_legend(nrow = 3, reverse = TRUE))

save_plot(last_plot(), "figs/arop/arop_composition_w_eu.png")

heatmap_data <- hh_r_silc_2023_national_arop |> 
  mutate(
    national_arop = fct_case_when(
      under_national_arop ~ "Pod národní hranicí chudoby", 
      TRUE ~ "Nad národní hranicí chudoby"
    ),
    deprivation = fct_case_when(
      severe_material_social_deprivation == 1 ~ "Vážně materiálně či sociálně deprivovaný",
      TRUE ~ "Není vážně deprivovaný"
    ),
    work_intensity = fct_case_when(
      low_work_intensity == 1 ~ "Nízká pracovní intenzita",
      low_work_intensity != 1 ~ "Dostatečná pracovní intenzita"
    ),
    country = fct_case_when(
      country == "Bulgaria" ~ "Bulharsko",
      country == "Hungary" ~ "Maďarsko",
      country == "Slovakia" ~ "Slovensko",
      country == "Greece" ~ "Řecko",
      country == "Romania" ~ "Rumunsko",
      country == "Croatia" ~ "Chorvatsko",
      country == "Latvia" ~ "Lotyšsko",
      country == "Lithuania" ~ "Litva",
      country == "Portugal" ~ "Portugalsko",
      country == "Estonia" ~ "Estonsko",
      country == "Poland" ~ "Polsko",
      country == "Czechia" ~ "Česko",
      country == "Malta" ~ "Malta",
      country == "Cyprus" ~ "Kypr",
      country == "Spain" ~ "Španělsko",
      country == "Slovenia" ~ "Slovinsko",
      country == "Italy" ~ "Itálie",
      country == "France" ~ "Francie",
      country == "Germany" ~ "Německo",
      country == "Sweden" ~ "Švédsko",
      country == "Denmark" ~ "Dánsko",
      country == "Belgium" ~ "Belgie",
      country == "Netherlands" ~ "Nizozemsko",
      country == "Finland" ~ "Finsko",
      country == "Ireland" ~ "Irsko",
      country == "Austria" ~ "Rakousko",
      country == "Luxembourg" ~ "Lucembursko"
    )
  ) |> 
  group_by(country, national_arop, deprivation, work_intensity) |> 
  summarise(n = sum(hh_cross_weight)) |> 
  group_by(country) |> 
  mutate(pct = n / sum(n))

heatmap_data |> 
  filter(!(deprivation == "Není vážně deprivovaný" & national_arop == "Nad národní hranicí chudoby" & work_intensity == "Dostatečná pracovní intenzita")) |> 
  ggplot(aes(x = work_intensity, y = country, fill = pct)) + 
  geom_tile() + 
  facet_wrap(deprivation ~ national_arop)

library(ggupset)

upset_chart_data <- hh_r_silc_2023_national_arop |> 
  mutate(
    national_arop = case_when(
      under_national_arop ~ "Pod národní hranicí chudoby", 
      TRUE ~ NA
    ),
    deprivation = case_when(
      severe_material_social_deprivation == 1 ~ "Vážně materiálně či sociálně deprivovaný",
      TRUE ~ NA
    ),
    work_intensity = case_when(
      low_work_intensity == 1 ~ "Nízká pracovní intenzita",
      low_work_intensity != 1 ~ NA
    ),
    country = fct_case_when(
      country == "Bulgaria" ~ "Bulharsko",
      country == "Hungary" ~ "Maďarsko",
      country == "Slovakia" ~ "Slovensko",
      country == "Greece" ~ "Řecko",
      country == "Romania" ~ "Rumunsko",
      country == "Croatia" ~ "Chorvatsko",
      country == "Latvia" ~ "Lotyšsko",
      country == "Lithuania" ~ "Litva",
      country == "Portugal" ~ "Portugalsko",
      country == "Estonia" ~ "Estonsko",
      country == "Poland" ~ "Polsko",
      country == "Czechia" ~ "Česko",
      country == "Malta" ~ "Malta",
      country == "Cyprus" ~ "Kypr",
      country == "Spain" ~ "Španělsko",
      country == "Slovenia" ~ "Slovinsko",
      country == "Italy" ~ "Itálie",
      country == "France" ~ "Francie",
      country == "Germany" ~ "Německo",
      country == "Sweden" ~ "Švédsko",
      country == "Denmark" ~ "Dánsko",
      country == "Belgium" ~ "Belgie",
      country == "Netherlands" ~ "Nizozemsko",
      country == "Finland" ~ "Finsko",
      country == "Ireland" ~ "Irsko",
      country == "Austria" ~ "Rakousko",
      country == "Luxembourg" ~ "Lucembursko"
    )
  ) |> 
  select(hh_id, country, hh_cross_weight, national_arop, deprivation, work_intensity) |> 
  tidyr::pivot_longer(cols = c(national_arop, deprivation, work_intensity)) |> 
  group_by(hh_id, country) |> 
  summarise(
    characteristics = list(value), .groups = "drop", 
    hh_cross_weight = unique(hh_cross_weight)
  ) |> 
  group_by(country, characteristics) |> 
  summarise(n = sum(hh_cross_weight), .groups = "drop") |> 
  group_by(country) |> 
  mutate(
    pct = n / sum(n), 
    n_nas = purrr::map_int(characteristics, ~sum(is.na(.x)))
  ) |> 
  # filter(country == "Česko") |> 
  filter(n_nas != 3)

upset_chart_data |> 
  filter(country == "Česko") |> 
  ggplot(aes(x = characteristics, y = pct)) + 
  geom_bar(stat = "identity") + 
  scale_x_upset() + 
  scale_y_continuous(labels = scales::label_percent(suffix = " %")) + 
  labs(x = "", y = "% domácností") + 
  theme_paq() + 
  theme(plot.margin = margin(2, 2, 2, 150))

upset_chart_data |> 
  ggplot(aes(x = characteristics, y = pct)) + 
  geom_bar(stat = "identity") + 
  scale_x_upset() + 
  scale_y_continuous(labels = scales::label_percent(suffix = " %"), limits = c(0, 0.21)) + 
  facet_wrap(~country, ncol = 5) + 
  theme_paq()

create_euler_data <- function(df, cntry){
  c(
  "Pod hranicí chudoby" = df |> 
  filter(country == !!cntry) |> 
  filter(national_arop == "Pod národní hranicí chudoby", 
         work_intensity == "Dostatečná pracovní intenzita", 
         deprivation == "Není vážně deprivovaný") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Nízká pracovní\nintenzita" = df |> 
  filter(country == !!cntry) |> 
  filter(work_intensity == "Nízká pracovní intenzita", 
         deprivation == "Není vážně deprivovaný",
         national_arop == "Nad národní hranicí chudoby") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Vážná materiální\nči sociální deprivace" = df |> 
  filter(country == !!cntry) |> 
  filter(deprivation == "Vážně materiálně či sociálně deprivovaný", 
         work_intensity == "Nízká pracovní intenzita", 
         national_arop == "Nad národní hranicí chudoby") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Pod hranicí chudoby&Nízká pracovní\nintenzita" = df |>
  filter(country == !!cntry) |>  
  filter(national_arop == "Pod národní hranicí chudoby", 
         work_intensity == "Nízká pracovní intenzita") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Pod hranicí chudoby&Vážná materiální\nči sociální deprivace" = df |> 
  filter(country == !!cntry) |> 
  filter(national_arop == "Pod národní hranicí chudoby", 
         deprivation == "Vážně materiálně či sociálně deprivovaný") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Nízká pracovní\nintenzita&Vážná materiální\nči sociální deprivace" = df |> 
  filter(country == !!cntry) |> 
  filter(work_intensity == "Nízká pracovní intenzita", 
          deprivation == "Vážně materiálně či sociálně deprivovaný") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Pod hranicí chudoby&Nízká pracovní\nintenzita&Vážná materiální\nči sociální deprivace" = df |> 
  filter(country == !!cntry) |> 
  filter(work_intensity == "Nízká pracovní intenzita", 
          deprivation == "Vážně materiálně či sociálně deprivovaný", 
          national_arop == "Pod národní hranicí chudoby") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct)
)
}

countries <- unique(heatmap_data$country)

euler_charts <- purrr::map(countries, function(x) {
  euler_df <- create_euler_data(heatmap_data, x)
  fit <-euler(euler_df, shape = "ellipse")
  plot(fit, quantities = TRUE, main = as.character(x), labels = FALSE)  
})

euler_mega_chart <- gridExtra::grid.arrange(
  euler_charts[[1]], euler_charts[[2]], euler_charts[[3]],
  euler_charts[[4]], euler_charts[[5]],
  euler_charts[[6]], euler_charts[[7]], euler_charts[[8]],
  euler_charts[[9]], euler_charts[[10]],
  euler_charts[[11]], euler_charts[[12]], euler_charts[[13]],
  euler_charts[[14]], euler_charts[[15]],
  euler_charts[[16]], euler_charts[[17]], euler_charts[[18]],
  euler_charts[[19]], euler_charts[[20]],
  euler_charts[[21]], euler_charts[[22]], euler_charts[[23]],
  euler_charts[[24]], euler_charts[[25]],
  euler_charts[[26]], euler_charts[[27]],
  ncol = 5
)

save_plot(euler_mega_chart, "figs/arop/euler_diagrams.png", width_px = 1000, height_px = 1000)

all_countries_heatmap_data <- hh_r_silc_2023_national_arop |> 
  mutate(
    national_arop = fct_case_when(
      under_national_arop ~ "Pod národní hranicí chudoby", 
      TRUE ~ "Nad národní hranicí chudoby"
    ),
    deprivation = fct_case_when(
      severe_material_social_deprivation == 1 ~ "Vážně materiálně či sociálně deprivovaný",
      TRUE ~ "Není vážně deprivovaný"
    ),
    work_intensity = fct_case_when(
      low_work_intensity == 1 ~ "Nízká pracovní intenzita",
      low_work_intensity != 1 ~ "Dostatečná pracovní intenzita"
    )
  ) |> 
  group_by(national_arop, deprivation, work_intensity) |> 
  summarise(n = sum(hh_cross_weight)) |> ungroup() |> 
  mutate(pct = n / sum(n))

eu_euler <- 
  c(
  "Pod hranicí chudoby" = all_countries_heatmap_data |> ungroup() |> 
  filter(national_arop == "Pod národní hranicí chudoby", 
         work_intensity == "Dostatečná pracovní intenzita", 
         deprivation == "Není vážně deprivovaný") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Nízká pracovní\nintenzita" = all_countries_heatmap_data |> ungroup() |> 
  filter(work_intensity == "Nízká pracovní intenzita", 
         deprivation == "Není vážně deprivovaný",
         national_arop == "Nad národní hranicí chudoby") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Vážná materiální\nči sociální deprivace" = all_countries_heatmap_data |> ungroup() |> 
  filter(deprivation == "Vážně materiálně či sociálně deprivovaný", 
         work_intensity == "Nízká pracovní intenzita", 
         national_arop == "Nad národní hranicí chudoby") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Pod hranicí chudoby&Nízká pracovní\nintenzita" = all_countries_heatmap_data |> ungroup() |> 
  filter(national_arop == "Pod národní hranicí chudoby", 
         work_intensity == "Nízká pracovní intenzita") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Pod hranicí chudoby&Vážná materiální\nči sociální deprivace" = all_countries_heatmap_data |> ungroup() |> 
  filter(national_arop == "Pod národní hranicí chudoby", 
         deprivation == "Vážně materiálně či sociálně deprivovaný") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Nízká pracovní\nintenzita&Vážná materiální\nči sociální deprivace" = all_countries_heatmap_data |> ungroup() |> 
  filter(work_intensity == "Nízká pracovní intenzita", 
          deprivation == "Vážně materiálně či sociálně deprivovaný") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Pod hranicí chudoby&Nízká pracovní\nintenzita&Vážná materiální\nči sociální deprivace" = all_countries_heatmap_data |> ungroup() |> 
  filter(work_intensity == "Nízká pracovní intenzita", 
          deprivation == "Vážně materiálně či sociálně deprivovaný", 
          national_arop == "Pod národní hranicí chudoby") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct)
)

eu_fit <- euler(eu_euler, shape = "ellipse")

AROPE s evropskou hranicí

arope_split2_data <- hh_r_silc_2023_national_arop |> 
  mutate(type = fct_case_when(
    under_arop ~ "Pod evropskou hranicí chudoby",
    severe_material_social_deprivation == 1 ~ "Vážně materiálně či sociálně deprivovaný",
    low_work_intensity == 1 ~ "Nízká pracovní intenzita", 
    TRUE ~ "není v AROPE", 
    new_levels = c("není v AROPE", "Nízká pracovní intenzita", "Vážně materiálně či sociálně deprivovaný", "Pod evropskou hranicí chudoby")
  ), 
    country = fct_case_when(
      country == "Bulgaria" ~ "Bulharsko",
      country == "Hungary" ~ "Maďarsko",
      country == "Slovakia" ~ "Slovensko",
      country == "Greece" ~ "Řecko",
      country == "Romania" ~ "Rumunsko",
      country == "Croatia" ~ "Chorvatsko",
      country == "Latvia" ~ "Lotyšsko",
      country == "Lithuania" ~ "Litva",
      country == "Portugal" ~ "Portugalsko",
      country == "Estonia" ~ "Estonsko",
      country == "Poland" ~ "Polsko",
      country == "Czechia" ~ "Česko",
      country == "Malta" ~ "Malta",
      country == "Cyprus" ~ "Kypr",
      country == "Spain" ~ "Španělsko",
      country == "Slovenia" ~ "Slovinsko",
      country == "Italy" ~ "Itálie",
      country == "France" ~ "Francie",
      country == "Germany" ~ "Německo",
      country == "Sweden" ~ "Švédsko",
      country == "Denmark" ~ "Dánsko",
      country == "Belgium" ~ "Belgie",
      country == "Netherlands" ~ "Nizozemsko",
      country == "Finland" ~ "Finsko",
      country == "Ireland" ~ "Irsko",
      country == "Austria" ~ "Rakousko",
      country == "Luxembourg" ~ "Lucembursko"
    )
  ) 
  
arope_split2 <- arope_split2_data |> 
  group_by(country, type) |> 
  summarise(n = sum(hh_cross_weight)) |> 
  group_by(country) |> 
  mutate(pct = n / sum(n))

eu_arope_split2 <- arope_split2_data |> 
  group_by(type) |> 
  summarise(n = sum(hh_cross_weight)) |> 
  ungroup() |> 
  mutate(pct = n / sum(n), 
         country = "EU")

arope_split_countries2 <- arope_split2 |> 
  filter(type == "není v AROPE") |> 
  arrange(desc(pct)) |> 
  pull(country)

arope_split2 |> 
  filter(type != "není v AROPE") |> 
  mutate(country = factor(country, levels = arope_split_countries2)) |> 
  ggplot(aes(x = country, y = pct, fill = type)) + 
  geom_bar(stat = "identity") + 
  theme_paq() + 
  scale_y_continuous(labels = scales::label_percent(suffix = " %"), expand = c(0, 0)) +
  scale_fill_manual(values = rev(paleta_kategoricka(3))) +
  coord_flip() +
  labs(x = "", y = "% domácností") + 
  guides(fill = guide_legend(nrow = 3, reverse = TRUE))

save_plot(last_plot(), "figs/arop/eu_arop_composition.png")

arope_split2 |> 
  bind_rows(eu_arope_split2) |> 
  filter(type != "není v AROPE") |> 
  mutate(country = factor(country, levels = c(as.character(arope_split_countries2), "EU"))) |> 
  ggplot(aes(x = country, y = pct, fill = type)) + 
  geom_bar(stat = "identity") + 
  theme_paq() + 
  scale_y_continuous(labels = scales::label_percent(suffix = " %"), expand = c(0, 0)) +
  scale_fill_manual(values = rev(paleta_kategoricka(3))) +
  coord_flip() +
  labs(x = "", y = "% domácností") + 
  guides(fill = guide_legend(nrow = 3, reverse = TRUE))

save_plot(last_plot(), "figs/arop/eu_arop_composition_w_eu.png")

eu_heatmap_data <- hh_r_silc_2023_national_arop |> 
  mutate(
    eu_arop = fct_case_when(
      under_arop ~ "Pod evropskou hranicí chudoby", 
      TRUE ~ "Nad evropskou hranicí chudoby"
    ),
    deprivation = fct_case_when(
      severe_material_social_deprivation == 1 ~ "Vážně materiálně či sociálně deprivovaný",
      TRUE ~ "Není vážně deprivovaný"
    ),
    work_intensity = fct_case_when(
      low_work_intensity == 1 ~ "Nízká pracovní intenzita",
      low_work_intensity != 1 ~ "Dostatečná pracovní intenzita"
    ),
    country = fct_case_when(
      country == "Bulgaria" ~ "Bulharsko",
      country == "Hungary" ~ "Maďarsko",
      country == "Slovakia" ~ "Slovensko",
      country == "Greece" ~ "Řecko",
      country == "Romania" ~ "Rumunsko",
      country == "Croatia" ~ "Chorvatsko",
      country == "Latvia" ~ "Lotyšsko",
      country == "Lithuania" ~ "Litva",
      country == "Portugal" ~ "Portugalsko",
      country == "Estonia" ~ "Estonsko",
      country == "Poland" ~ "Polsko",
      country == "Czechia" ~ "Česko",
      country == "Malta" ~ "Malta",
      country == "Cyprus" ~ "Kypr",
      country == "Spain" ~ "Španělsko",
      country == "Slovenia" ~ "Slovinsko",
      country == "Italy" ~ "Itálie",
      country == "France" ~ "Francie",
      country == "Germany" ~ "Německo",
      country == "Sweden" ~ "Švédsko",
      country == "Denmark" ~ "Dánsko",
      country == "Belgium" ~ "Belgie",
      country == "Netherlands" ~ "Nizozemsko",
      country == "Finland" ~ "Finsko",
      country == "Ireland" ~ "Irsko",
      country == "Austria" ~ "Rakousko",
      country == "Luxembourg" ~ "Lucembursko"
    )
  ) |> 
  group_by(country, eu_arop, deprivation, work_intensity) |> 
  summarise(n = sum(hh_cross_weight)) |> 
  group_by(country) |> 
  mutate(pct = n / sum(n))

create_eu_euler_data <- function(df, cntry){
  c(
  "Pod hranicí chudoby" = df |> 
  filter(country == !!cntry) |> 
  filter(eu_arop == "Pod evropskou hranicí chudoby", 
         work_intensity == "Dostatečná pracovní intenzita", 
         deprivation == "Není vážně deprivovaný") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Nízká pracovní\nintenzita" = df |> 
  filter(country == !!cntry) |> 
  filter(work_intensity == "Nízká pracovní intenzita", 
         eu_arop == "Nad evropskou hranicí chudoby", 
         deprivation == "Není vážně deprivovaný") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Vážná materiální\nči sociální deprivace" = df |> 
  filter(country == !!cntry) |> 
  filter(deprivation == "Vážně materiálně či sociálně deprivovaný", 
         eu_arop == "Nad evropskou hranicí chudoby", 
         work_intensity == "Dostatečná pracovní intenzita") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Pod hranicí chudoby&Nízká pracovní\nintenzita" = df |>
  filter(country == !!cntry) |>  
  filter(eu_arop == "Pod evropskou hranicí chudoby", 
         work_intensity == "Nízká pracovní intenzita") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Pod hranicí chudoby&Vážná materiální\nči sociální deprivace" = df |> 
  filter(country == !!cntry) |> 
  filter(eu_arop == "Pod evropskou hranicí chudoby", 
         deprivation == "Vážně materiálně či sociálně deprivovaný") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Nízká pracovní\nintenzita&Vážná materiální\nči sociální deprivace" = df |> 
  filter(country == !!cntry) |> 
  filter(work_intensity == "Nízká pracovní intenzita", 
          deprivation == "Vážně materiálně či sociálně deprivovaný") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Pod hranicí chudoby&Nízká pracovní\nintenzita&Vážná materiální\nči sociální deprivace" = df |> 
  filter(country == !!cntry) |> 
  filter(work_intensity == "Nízká pracovní intenzita", 
          deprivation == "Vážně materiálně či sociálně deprivovaný", 
          eu_arop == "Pod evropskou hranicí chudoby") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct)
)
}

countries <- unique(eu_heatmap_data$country)

eu_euler_charts <- purrr::map(countries, function(x) {
  euler_df <- create_eu_euler_data(eu_heatmap_data, x)
  fit <-euler(euler_df, shape = "ellipse")
  plot(fit, quantities = TRUE, main = as.character(x), labels = FALSE)  
})

eu_euler_mega_chart <- gridExtra::grid.arrange(
  eu_euler_charts[[1]], eu_euler_charts[[2]], eu_euler_charts[[3]],
  eu_euler_charts[[4]], eu_euler_charts[[5]],
  eu_euler_charts[[6]], eu_euler_charts[[7]], eu_euler_charts[[8]],
  eu_euler_charts[[9]], eu_euler_charts[[10]],
  eu_euler_charts[[11]], eu_euler_charts[[12]], eu_euler_charts[[13]],
  eu_euler_charts[[14]], eu_euler_charts[[15]],
  eu_euler_charts[[16]], eu_euler_charts[[17]], eu_euler_charts[[18]],
  eu_euler_charts[[19]], eu_euler_charts[[20]],
  eu_euler_charts[[21]], eu_euler_charts[[22]], eu_euler_charts[[23]],
  eu_euler_charts[[24]], eu_euler_charts[[25]],
  eu_euler_charts[[26]], eu_euler_charts[[27]],
  ncol = 5
)

save_plot(eu_euler_mega_chart, "figs/arop/euler_eu_diagrams.png", 
          width_px = 1000, height_px = 1000)

all_countries_eu_heatmap_data <- hh_r_silc_2023_national_arop |> 
  mutate(
    eu_arop = fct_case_when(
      under_arop ~ "Pod evropskou hranicí chudoby", 
      TRUE ~ "Nad evropskou hranicí chudoby"
    ),
    deprivation = fct_case_when(
      severe_material_social_deprivation == 1 ~ "Vážně materiálně či sociálně deprivovaný",
      TRUE ~ "Není vážně deprivovaný"
    ),
    work_intensity = fct_case_when(
      low_work_intensity == 1 ~ "Nízká pracovní intenzita",
      low_work_intensity != 1 ~ "Dostatečná pracovní intenzita"
    )
  ) |> 
  group_by(eu_arop, deprivation, work_intensity) |> 
  summarise(n = sum(hh_cross_weight)) |> ungroup() |> 
  mutate(pct = n / sum(n))

all_countries_euler_df <- c(
  "Pod EU hranicí chudoby" = all_countries_eu_heatmap_data |> 
  filter(eu_arop == "Pod evropskou hranicí chudoby", 
         work_intensity == "Dostatečná pracovní intenzita", 
         deprivation == "Není vážně deprivovaný") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Nízká pracovní\nintenzita" = all_countries_eu_heatmap_data |> 
  filter(work_intensity == "Nízká pracovní intenzita", 
         eu_arop == "Nad evropskou hranicí chudoby", 
         deprivation == "Není vážně deprivovaný") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Vážná materiální\nči sociální deprivace" = all_countries_eu_heatmap_data |> 
  filter(deprivation == "Vážně materiálně či sociálně deprivovaný", 
         eu_arop == "Nad evropskou hranicí chudoby", 
         work_intensity == "Dostatečná pracovní intenzita") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Pod EU hranicí chudoby&Nízká pracovní\nintenzita" = all_countries_eu_heatmap_data |>
  filter(eu_arop == "Pod evropskou hranicí chudoby", 
         work_intensity == "Nízká pracovní intenzita") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Pod EU hranicí chudoby&Vážná materiální\nči sociální deprivace" = all_countries_eu_heatmap_data |> 
  filter(eu_arop == "Pod evropskou hranicí chudoby", 
         deprivation == "Vážně materiálně či sociálně deprivovaný") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Nízká pracovní\nintenzita&Vážná materiální\nči sociální deprivace" = all_countries_eu_heatmap_data |> 
  filter(work_intensity == "Nízká pracovní intenzita", 
          deprivation == "Vážně materiálně či sociálně deprivovaný") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct),
  "Pod EU hranicí chudoby&Nízká pracovní\nintenzita&Vážná materiální\nči sociální deprivace" = all_countries_eu_heatmap_data |> 
  filter(work_intensity == "Nízká pracovní intenzita", 
          deprivation == "Vážně materiálně či sociálně deprivovaný", 
          eu_arop == "Pod evropskou hranicí chudoby") |> 
  summarise(pct = round(sum(pct) * 100, 1)) |> 
  pull(pct)
)

fit <-euler(all_countries_euler_df, shape = "ellipse")
plot(fit, quantities = TRUE, main = "EU", labels = TRUE)  

Bez indikátoru “nemůže si dovolit nečekané výdaje ve výši 60% mediánového příjmu”

aropes2 <- hh_r_silc_2023_national_arop %>% 
  mutate(arope = under_national_arop | 
           low_work_intensity == 1 | 
           sum_deprived_items_wo_expenses > 6, 
         eu_arope = under_eu_poverty | 
           low_work_intensity == 1 | 
           sum_deprived_items_wo_expenses > 6) %>% 
  group_by(country) %>% 
  summarise(
    pct_eu_arope = wtd.mean(eu_arope, hh_cross_weight), 
    pct_national_arope = wtd.mean(arope, hh_cross_weight)
  ) %>% 
  mutate(
    country = fct_case_when(
      country == "Bulgaria" ~ "Bulharsko",
      country == "Hungary" ~ "Maďarsko",
      country == "Slovakia" ~ "Slovensko",
      country == "Greece" ~ "Řecko",
      country == "Romania" ~ "Rumunsko",
      country == "Croatia" ~ "Chorvatsko",
      country == "Latvia" ~ "Lotyšsko",
      country == "Lithuania" ~ "Litva",
      country == "Portugal" ~ "Portugalsko",
      country == "Estonia" ~ "Estonsko",
      country == "Poland" ~ "Polsko",
      country == "Czechia" ~ "Česko",
      country == "Malta" ~ "Malta",
      country == "Cyprus" ~ "Kypr",
      country == "Spain" ~ "Španělsko",
      country == "Slovenia" ~ "Slovinsko",
      country == "Italy" ~ "Itálie",
      country == "France" ~ "Francie",
      country == "Germany" ~ "Německo",
      country == "Sweden" ~ "Švédsko",
      country == "Denmark" ~ "Dánsko",
      country == "Belgium" ~ "Belgie",
      country == "Netherlands" ~ "Nizozemsko",
      country == "Finland" ~ "Finsko",
      country == "Ireland" ~ "Irsko",
      country == "Austria" ~ "Rakousko",
      country == "Luxembourg" ~ "Lucembursko"
    )
  ) 

aropes2 %>% 
  ggplot(., aes(x = pct_eu_arope, y = pct_national_arope)) + 
  geom_smooth(method = "lm", se = FALSE, colour = "gray80") + 
  geom_text_repel(aes(label = country)) + 
  geom_point() + 
  scale_x_continuous(labels = scales::label_percent(suffix = " %")) +
  scale_y_continuous(labels = scales::label_percent(suffix = " %")) + 
  theme_paq() + 
  labs(x = "Podíl domácností v ohrožení EU chudobou (50 % evropského mediánu) a sociálním vyloučením", 
       y = "Podíl domácností v ohrožení národní chudobou (60 % národního mediánu) a sociálním vyloučením")

cntry_levels <- aropes2 |> arrange(pct_eu_arope) |> pull(country)
aropes2 %>% 
  tidyr::pivot_longer(cols = c(pct_eu_arope, pct_national_arope)) %>% 
  mutate(name = case_when(
    name == "pct_eu_arope" ~ "Podíl domácností v ohrožení EU chudobou (50 % evropského mediánu) a sociálním vyloučením", 
    name == "pct_national_arope" ~ "Podíl domácností v ohrožení národní chudobou (60 % národního mediánu) a sociálním vyloučením"
  ), country = factor(country, levels = rev(cntry_levels))) %>% 
  ggplot(., aes(x = country, y = value, fill = name)) + 
  geom_bar(stat = "identity", position = "dodge") + 
  scale_y_continuous(labels = scales::label_percent(suffix = " %")) + 
  scale_fill_manual(values = paleta_kategoricka(2)) + 
  coord_flip() + 
  theme_paq() + 
  guides(fill = guide_legend(nrow = 2)) + 
  labs(x = "", y = "")

save_plot(last_plot(), 
          "figs/arop/arope_bez_indikatoru.png")

arop_deprivation <- hh_r_silc_2023_national_arop |> 
  group_by(country) |> 
  summarise(
    under_national_arop = wtd.mean(under_national_arop, hh_cross_weight) * 100, 
    under_eu_arop = wtd.mean(under_arop, hh_cross_weight) * 100, 
    material_deprivation = wtd.mean(severe_material_social_deprivation, hh_cross_weight) * 100
  ) |> 
  mutate(
    country = fct_case_when(
      country == "Bulgaria" ~ "Bulharsko",
      country == "Hungary" ~ "Maďarsko",
      country == "Slovakia" ~ "Slovensko",
      country == "Greece" ~ "Řecko",
      country == "Romania" ~ "Rumunsko",
      country == "Croatia" ~ "Chorvatsko",
      country == "Latvia" ~ "Lotyšsko",
      country == "Lithuania" ~ "Litva",
      country == "Portugal" ~ "Portugalsko",
      country == "Estonia" ~ "Estonsko",
      country == "Poland" ~ "Polsko",
      country == "Czechia" ~ "Česko",
      country == "Malta" ~ "Malta",
      country == "Cyprus" ~ "Kypr",
      country == "Spain" ~ "Španělsko",
      country == "Slovenia" ~ "Slovinsko",
      country == "Italy" ~ "Itálie",
      country == "France" ~ "Francie",
      country == "Germany" ~ "Německo",
      country == "Sweden" ~ "Švédsko",
      country == "Denmark" ~ "Dánsko",
      country == "Belgium" ~ "Belgie",
      country == "Netherlands" ~ "Nizozemsko",
      country == "Finland" ~ "Finsko",
      country == "Ireland" ~ "Irsko",
      country == "Austria" ~ "Rakousko",
      country == "Luxembourg" ~ "Lucembursko"
    )
  )

cor(arop_deprivation$under_national_arop, arop_deprivation$material_deprivation)

## [1] 0.105053

cor(arop_deprivation$under_eu_arop, arop_deprivation$material_deprivation)

## [1] 0.5996177

r2_label <- tibble(
  x = 10, 
  y = 20, 
  label = "r<sup>2</sup>=0.01"
)

chart_national_depr <- ggplot(arop_deprivation, aes(x = under_national_arop, y = material_deprivation)) + 
  geom_point() + 
  geom_text_repel(aes(label = country)) + 
  geom_richtext(aes(x = x, y = y, label = label), 
                data = r2_label, hjust = 0, 
                fill = NA, label.colour = NA) + 
  geom_smooth(method = "lm", se = FALSE) + 
  scale_y_continuous(labels = scales::label_percent(scale = 1, suffix = " %")) +
  scale_x_continuous(labels = scales::label_percent(scale = 1, suffix = " %")) + 
  # coord_equal() + 
  theme_paq() + 
  labs(x = "% domácností pod národní hranicí chudoby", 
       y = "% domácností ve vážné materiální nebo sociální deprivaci")

eu_r2_label <- tibble(
  x = 3.4, 
  y = 20, 
  label = "r<sup>2</sup>=0.36"
)

chart_eu_depr <- ggplot(arop_deprivation, aes(x = under_eu_arop, y = material_deprivation)) + 
  geom_point() + 
  geom_text_repel(aes(label = country)) + 
  geom_smooth(method = "lm", se = FALSE) + 
  geom_richtext(aes(x = x, y = y, label = label), 
                data = eu_r2_label, hjust = 0, 
                fill = NA, label.colour = NA) + 
  # coord_equal() + 
  scale_y_continuous(labels = scales::label_percent(scale = 1, suffix = " %")) +
  scale_x_continuous(labels = scales::label_percent(scale = 1, suffix = " %")) + 
  theme_paq() + 
  labs(x = "% domácností pod evropskou hranicí chudoby", 
       y = "% domácností ve vážné materiální nebo sociální deprivaci")

chart_national_depr | chart_eu_depr

save_plot(plot = last_plot(),
          path = "figs/arop/scatter_arop_deprivation.png")

eu_dens <- density(hh_r_silc_2023_national_arop$income_disposable_eqi_ppp, n = 50000)
eu_density_df <- tibble(
  country = "EU", 
  x = eu_dens$x, 
  y = eu_dens$y
)

density_df %>% 
  left_join(., country_q95, by = "country") %>% 
  filter(x <= q95) %>% 
bind_rows(
  ., 
  eu_density_df
) %>% 
  mutate(under_eu_arop = x < EU_MEDIAN_60PCT) %>% 
  mutate(
    country = fct_case_when(
      country == "Bulgaria" ~ "Bulharsko",
      country == "Hungary" ~ "Maďarsko",
      country == "Slovakia" ~ "Slovensko",
      country == "Greece" ~ "Řecko",
      country == "Romania" ~ "Rumunsko",
      country == "Croatia" ~ "Chorvatsko",
      country == "Latvia" ~ "Lotyšsko",
      country == "Lithuania" ~ "Litva",
      country == "Portugal" ~ "Portugalsko",
      country == "Estonia" ~ "Estonsko",
      country == "Poland" ~ "Polsko",
      country == "Czechia" ~ "Česko",
      country == "Malta" ~ "Malta",
      country == "Cyprus" ~ "Kypr",
      country == "Spain" ~ "Španělsko",
      country == "Slovenia" ~ "Slovinsko",
      country == "Italy" ~ "Itálie",
      country == "France" ~ "Francie",
      country == "Germany" ~ "Německo",
      country == "Sweden" ~ "Švédsko",
      country == "Denmark" ~ "Dánsko",
      country == "Belgium" ~ "Belgie",
      country == "Netherlands" ~ "Nizozemsko",
      country == "Finland" ~ "Finsko",
      country == "Ireland" ~ "Irsko",
      country == "Austria" ~ "Rakousko",
      country == "Luxembourg" ~ "Lucembursko", 
      country == "EU" ~ "EU"
    ), 
    under_eu_arop = factor(under_eu_arop, levels = c(TRUE, FALSE), 
    labels = c("Pod evropskou hranicí příjmové chudoby (60 % evropského mediánu)", "Nad evropskou hranicí chudoby"))  
  ) %>% 
  ggplot(., aes(x = x, y = country,
                height = y * 10000, fill = under_eu_arop)) + 
  geom_vline(xintercept = EU_MEDIAN_60PCT, colour = "red") + 
  geom_vline(xintercept = EU_MEDIAN_50PCT, colour = "darkred") + 
  # geom_vline(xintercept = CZ_MEDIAN_60PCT, colour = "blue") + 
  geom_ridgeline_gradient() + 
  scale_x_continuous(limits = c(0, 75000), labels = scales::comma_format(big.mark = " ")) + 
  scale_fill_manual(values = c("Pod evropskou hranicí příjmové chudoby (60 % evropského mediánu)" = "#ECB925", 
                               "Nad evropskou hranicí chudoby" = "gray80")) + 
  theme_paq() + 
  # theme(legend.position = "none") + 
  labs(x = "Ekvivalizovaný příjem domácnosti ve standardu kupní síly", y = "") + 
  geom_curve(x = 51000, xend = EU_MEDIAN_50PCT + 500, y = 24, yend = 27, 
            curvature = -0.05, colour = "darkred",
            arrow = arrow(length = unit(0.1, "cm"))) + 
  annotate("text", x = 62500, y = 24, label = "50 % evropského mediánu", 
           colour = "darkred") + 
  geom_curve(x = 51000, xend = EU_MEDIAN_60PCT + 500, y = 23, yend = 26, 
            curvature = -0.05, colour = "red",
            arrow = arrow(length = unit(0.1, "cm"))) + 
  annotate("text", x = 62500, y = 23, label = "60 % evropského mediánu", 
           colour = "red") +  
  guides(fill = guide_legend(nrow = 2))

save_plot(plot = last_plot(),
          path = "figs/arop/arop1_eu_arrows.png", 
          height_px = 600, 
          width_px = 600)

hh_r_silc_2023_national_arop %>% 
  group_by(country) %>% 
  summarise(
    under_national_arop = wtd.mean(under_national_arop, hh_cross_weight), 
    under_eu_poverty = wtd.mean(under_eu_poverty, hh_cross_weight), 
    under_eu_arop = wtd.mean(under_arop, hh_cross_weight)
  ) %>% 
  mutate(
    country = fct_case_when(
      country == "Bulgaria" ~ "Bulharsko",
      country == "Hungary" ~ "Maďarsko",
      country == "Slovakia" ~ "Slovensko",
      country == "Greece" ~ "Řecko",
      country == "Romania" ~ "Rumunsko",
      country == "Croatia" ~ "Chorvatsko",
      country == "Latvia" ~ "Lotyšsko",
      country == "Lithuania" ~ "Litva",
      country == "Portugal" ~ "Portugalsko",
      country == "Estonia" ~ "Estonsko",
      country == "Poland" ~ "Polsko",
      country == "Czechia" ~ "Česko",
      country == "Malta" ~ "Malta",
      country == "Cyprus" ~ "Kypr",
      country == "Spain" ~ "Španělsko",
      country == "Slovenia" ~ "Slovinsko",
      country == "Italy" ~ "Itálie",
      country == "France" ~ "Francie",
      country == "Germany" ~ "Německo",
      country == "Sweden" ~ "Švédsko",
      country == "Denmark" ~ "Dánsko",
      country == "Belgium" ~ "Belgie",
      country == "Netherlands" ~ "Nizozemsko",
      country == "Finland" ~ "Finsko",
      country == "Ireland" ~ "Irsko",
      country == "Austria" ~ "Rakousko",
      country == "Luxembourg" ~ "Lucembursko", 
      country == "EU" ~ "EU"
    )
  ) %>% 
  ggplot(., aes(x = under_national_arop, y = under_eu_poverty)) + 
  geom_point() + 
  geom_text_repel(aes(label = country)) + 
  geom_smooth(se = FALSE, method = "lm") + 
  scale_x_continuous(labels = scales::label_percent(scale = 100, suffix = " %")) + 
  scale_y_continuous(labels = scales::label_percent(scale = 100, suffix = " %")) + 
  theme_paq() + 
  labs(x = "Pod hranicí 60 % národního mediánu", 
       y = "Pod hranicí 50 % evropského mediánu")

save_plot(last_plot(), "figs/arop/arop_scatter.png", 
          width_px = 640, height_px = 640)

Materiální deprivace vs. národní AROP

hh_r_silc_2023_national_arop |> 
  filter(!is.na(sum_deprived_items)) |> 
  mutate(r_sum_deprived_items = fct_case_when(
    sum_deprived_items >= 10 ~ "10 a více", 
    sum_deprived_items >= 7 ~ "7-9", 
    sum_deprived_items >= 4 ~ "4-6",
    sum_deprived_items >= 3 ~ "3-5", 
    sum_deprived_items >= 1 ~ "1-2",
    sum_deprived_items == 0 ~ "0"
  )) |> 
  group_by(country, r_sum_deprived_items, under_national_arop) |> 
  summarise(n = sum(hh_cross_weight)) |> 
  group_by(country, r_sum_deprived_items) |> 
  mutate(pct = n / sum(n) * 100) |> 
  ggplot(aes(x = r_sum_deprived_items, y = pct, fill = under_national_arop)) + 
  geom_bar(stat = "identity") + 
  coord_flip() + 
  facet_wrap(~country) + 
  theme_paq()

hh_r_silc_2023_national_arop |> 
  group_by(country, under_national_arop) |> 
  ggplot(aes(x = under_national_arop, y = sum_deprived_items, fill = under_national_arop)) + 
  geom_boxplot(outliers = FALSE) + 
  facet_wrap(~country) + 
  theme_paq()

Materiální deprivace vs. evropský AROP

hh_r_silc_2023_national_arop |> 
  filter(!is.na(sum_deprived_items)) |> 
  mutate(r_sum_deprived_items = fct_case_when(
    sum_deprived_items >= 10 ~ "10 a více", 
    sum_deprived_items >= 7 ~ "7-9", 
    sum_deprived_items >= 4 ~ "4-6",
    sum_deprived_items >= 3 ~ "3-5", 
    sum_deprived_items >= 1 ~ "1-2",
    sum_deprived_items == 0 ~ "0"
  )) |> 
  group_by(country, r_sum_deprived_items, under_arop) |> 
  summarise(n = sum(hh_cross_weight)) |> 
  group_by(country, r_sum_deprived_items) |> 
  mutate(pct = n / sum(n) * 100) |> 
  ggplot(aes(x = r_sum_deprived_items, y = pct, fill = under_arop)) + 
  geom_bar(stat = "identity") + 
  coord_flip() + 
  facet_wrap(~country) + 
  theme_paq()

hh_r_silc_2023_national_arop |> 
  group_by(country, under_arop) |> 
  ggplot(aes(x = under_arop, y = sum_deprived_items, fill = under_arop)) + 
  geom_boxplot(outliers = FALSE) + 
  facet_wrap(~country) + 
  theme_paq()

Deprivace bez výdajů

hh_r_silc_2023_national_arop |> 
  group_by(country, sum_deprived_items_wo_expenses, under_national_arop) |> 
  summarise(n = sum(hh_cross_weight)) |> 
  group_by(country, sum_deprived_items_wo_expenses) |> 
  mutate(pct = n / sum(n) * 100) |> 
  ggplot(aes(x = sum_deprived_items_wo_expenses, y = pct, fill = under_national_arop)) + 
  geom_bar(stat = "identity") + 
  coord_flip() + 
  facet_wrap(~country) + 
  theme_paq()

hh_r_silc_2023_national_arop |> 
  group_by(country, under_national_arop) |> 
  ggplot(aes(x = under_national_arop, y = sum_deprived_items_wo_expenses, 
             fill = under_national_arop)) + 
  geom_boxplot(outliers = FALSE) + 
  facet_wrap(~country) + 
  theme_paq()

hh_r_silc_2023_national_arop |> 
  group_by(country, sum_deprived_items_wo_expenses, under_arop) |> 
  summarise(n = sum(hh_cross_weight)) |> 
  group_by(country, sum_deprived_items_wo_expenses) |> 
  mutate(pct = n / sum(n) * 100) |> 
  ggplot(aes(x = sum_deprived_items_wo_expenses, y = pct, fill = under_arop)) + 
  geom_bar(stat = "identity") + 
  coord_flip() + 
  facet_wrap(~country) + 
  theme_paq()

hh_r_silc_2023_national_arop |> 
  group_by(country, under_arop) |> 
  ggplot(aes(x = under_arop, y = sum_deprived_items_wo_expenses, 
             fill = under_arop)) + 
  geom_boxplot(outliers = FALSE) + 
  facet_wrap(~country) + 
  theme_paq()

hh_r_silc_2023_national_arop |> 
  group_by(country) |> 
  summarise(
    cor_eu_arop_deprivation = cor(under_arop, sum_deprived_items, 
                                  use = "pairwise.complete.obs", method = "spearman"), 
    cor_national_arop_deprivation = cor(under_national_arop, sum_deprived_items, 
                                        use = "pairwise.complete.obs", method = "spearman")
  ) |> 
  knitr::kable(digits = 2)

country	cor_eu_arop_deprivation	cor_national_arop_deprivation
Austria	0.17	0.31
Belgium	0.14	0.27
Bulgaria	0.46	0.30
Croatia	0.51	0.48
Cyprus	0.35	0.36
Czechia	0.37	0.28
Denmark	0.15	0.19
Estonia	0.34	0.32
Finland	0.25	0.27
France	0.28	0.33
Germany	0.23	0.27
Greece	0.53	0.43
Hungary	0.41	0.31
Ireland	0.15	0.32
Italy	0.26	0.27
Latvia	0.43	0.36
Lithuania	0.39	0.34
Luxembourg	0.13	0.36
Malta	0.20	0.21
Netherlands	0.15	0.27
Poland	0.38	0.32
Portugal	0.43	0.34
Romania	0.44	0.33
Slovakia	0.35	0.31
Slovenia	0.32	0.33
Spain	0.33	0.33
Sweden	0.25	0.26

Rozdíly v AROP podle typu domácnosti

Typ bydlení

bydleni_data <- hh_r_silc_2023_arop %>% 
  group_by(r_country, r_tenure_status) %>% 
  summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100) %>% 
  filter(!is.na(r_tenure_status)) %>% 
  mutate(r_tenure_status = factor(r_tenure_status, 
                                  levels = c("Owner", "Tenant"), 
                                  labels = c("Majitelé", "Nájemníci"))) 
                                   
ggplot(bydleni_data, aes(x = r_tenure_status, y = pct_under_arop, fill = r_country)) + 
  geom_bar(stat = "identity", position = "dodge") + 
  scale_y_continuous(labels = scales::label_percent(scale = 1)) + 
  scale_fill_manual(values = paleta_kategoricka(2)) + 
  labs(x = "", y = "% domácností pod evropskou hranicí chudoby") + 
  coord_flip() +
  theme_paq()

save_plot(last_plot(), 
          "figs/arop/tenants.png")

hh_r_silc_2023_arop %>% 
  group_by(country, r_tenure_status) %>% 
  summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100) %>% 
  filter(!is.na(r_tenure_status)) %>% 
  ggplot(., aes(x = r_tenure_status, y = pct_under_arop)) + 
  geom_bar(stat = "identity") + 
  scale_y_continuous(labels = scales::label_percent(scale = 1)) + 
  labs(x = "", y = "% under EU AROP") + 
  coord_flip() +
  facet_wrap(vars(country), ncol = 4) + 
  theme_paq()

# # arrange(pct_under_arop) %>% 
#   knitr::kable(., digits = 2, col.names = c("Country", "Tenure", "% under EU AROP"))

Typ domácnosti

typ_domacnosti_data <- hh_r_silc_2023_arop %>% 
  group_by(r_country, typ_domacnosti) %>% 
  summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100) %>% 
  # filter(!is.na(tenure_status)) %>% 
  mutate(typ_domacnosti = factor(typ_domacnosti, levels = c("Ostatní", "Samoživitel/ka s dětmi", "Samostatně žijící senior", "Dvojice seniorů", "Úplná domácnost s dětmi")))

ggplot(typ_domacnosti_data, aes(x = typ_domacnosti, y = pct_under_arop, fill = r_country)) + 
  geom_bar(stat = "identity", position = "dodge") + 
  scale_y_continuous(labels = scales::label_percent(scale = 1)) + 
  scale_fill_manual(values = paleta_kategoricka(2)) + 
  labs(x = "", y = "% domácností pod evropskou hranicí chudoby") + 
  coord_flip() +
  theme_paq()

save_plot(last_plot(),
          "figs/arop/typ_hh.png")

hh_r_silc_2023_arop %>% 
  group_by(r_country, low_work_intensity) %>% 
  mutate(low_work_intensity = as_factor(low_work_intensity)) |> 
  mutate(low_work_intensity = factor(low_work_intensity, 
          levels = c("Not applicable", "Low work intensity", "No low work intensity"), 
          labels = c("Domácnosti 65+", "Domácnosti s nízkou pracovní intenzitou", 
                     "Ekonomicky aktivní domácnosti\n(bez nízké pracovní intenzity)")
  )) |> 
  summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100) %>% 
  # filter(!is.na(tenure_status)) %>% 
  ggplot(aes(x = low_work_intensity, y = pct_under_arop, fill = r_country)) + 
  geom_bar(stat = "identity", position = "dodge") + 
  scale_y_continuous(labels = scales::label_percent(scale = 1)) + 
  scale_fill_manual(values = paleta_kategoricka(2)) + 
  labs(x = "", y = "% domácností pod evropskou hranicí chudoby") + 
  coord_flip() +
  theme_paq()

save_plot(last_plot(),
          "figs/arop/typ_ea.png")

hh_r_silc_2023_arop %>% 
  group_by(country, typ_domacnosti) %>% 
  summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100) %>% 
  # filter(!is.na(tenure_status)) %>% 
  ggplot(., aes(x = typ_domacnosti, y = pct_under_arop)) + 
  geom_bar(stat = "identity") + 
  scale_y_continuous(labels = scales::label_percent(scale = 1)) + 
  labs(x = "", y = "% under EU AROP") + 
  coord_flip() +
  facet_wrap(vars(country), ncol = 4) + 
  theme_paq()

Region

hh_r_silc_2023_arop %>% 
  group_by(r_country, region_typ) %>% 
  summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100) %>% 
  filter(!is.na(region_typ)) %>% 
  ggplot(., aes(x = region_typ, y = pct_under_arop, fill = r_country)) + 
  geom_bar(stat = "identity", position = "dodge") + 
  scale_y_continuous(labels = scales::label_percent(scale = 1)) + 
  labs(x = "", y = "% under EU AROP") + 
  coord_flip() +
  theme_paq()

hh_r_silc_2023_arop %>% 
  group_by(country, region_typ) %>% 
  summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100) %>% 
  filter(!is.na(region_typ)) %>% 
  ggplot(., aes(x = region_typ, y = pct_under_arop)) + 
  geom_bar(stat = "identity") + 
  scale_y_continuous(labels = scales::label_percent(scale = 1)) + 
  labs(x = "", y = "% under EU AROP") + 
  coord_flip() +
  facet_wrap(vars(country), ncol = 4) + 
  theme_paq()

Ekonomická aktivita

hh_r_silc_2023_arop |> 
  group_by(r_country, econ_status) %>% 
  summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100) %>% 
  filter(!is.na(econ_status)) %>% 
  ggplot(., aes(x = econ_status, y = pct_under_arop, 
                fill = r_country)) + 
  geom_bar(stat = "identity", position = "dodge") + 
  scale_y_continuous(labels = scales::label_percent(scale = 1)) + 
  labs(x = "", y = "% under EU AROP") + 
  coord_flip() +
  theme_paq()

hh_r_silc_2023_arop |> 
  group_by(country, econ_status) %>% 
  summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100) %>% 
  filter(!is.na(econ_status)) %>% 
  ggplot(., aes(x = econ_status, y = pct_under_arop)) + 
  geom_bar(stat = "identity") + 
  scale_y_continuous(labels = scales::label_percent(scale = 1)) + 
  labs(x = "", y = "% under EU AROP") + 
  coord_flip() +
  facet_wrap(vars(country), ncol = 4) + 
  theme_paq()

Ekon. aktivní podle vzdělání (domácnosti bez 65+, vzdělání referenční osoby)

vzdelani_data <- hh_r_silc_2023_arop %>% 
  # filter(hh_old == "Bez 65+") %>% 
  mutate(rr_education = fct_case_when(
    r_education %in% c("First stage tertiary", "Second stage tertiary") ~ "Vysokoškolské",
    r_education %in% c("Pre-primary", "Primary", "Lower secondary", 
    "Upper secondary", "Post-secondary non-tertiary") ~ "Střední a nižší"
  )) %>% 
  group_by(r_country, rr_education) %>% 
  summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100) %>% 
  filter(!is.na(rr_education))

ggplot(vzdelani_data, aes(x = rr_education, y = pct_under_arop, fill = r_country)) + 
  geom_bar(stat = "identity", position = "dodge") + 
  scale_y_continuous(labels = scales::label_percent(scale = 1)) + 
  labs(x = "", y = "% under EU AROP") + 
  coord_flip() +
  theme_paq()

hh_r_silc_2023_arop %>% 
  filter(hh_old == "Bez 65+") %>% 
  mutate(rr_education = fct_case_when(
    r_education %in% c("Pre-primary", "Primary") ~ "Základní a nedokončené základní",
    r_education %in% c("Lower secondary", "Upper secondary") ~ "Střední",
    r_education %in% c("Post-secondary non-tertiary", "First stage tertiary", 
                       "Second stage tertiary") ~ "Vysokoškolské"
  )) %>% 
  group_by(country, rr_education) %>% 
  summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100) %>% 
  filter(!is.na(rr_education)) %>% 
  ggplot(., aes(x = rr_education, y = pct_under_arop)) + 
  geom_bar(stat = "identity") + 
  scale_y_continuous(labels = scales::label_percent(scale = 1)) + 
  labs(x = "", y = "% under EU AROP") + 
  coord_flip() +
  facet_wrap(vars(country), ncol = 4) + 
  theme_paq()

##### Small multiple chart

bind_rows(
  vzdelani_data |> 
    ungroup() |> 
    rename(category = rr_education) |> 
    mutate(indicator = "Vzdělání"),
  bydleni_data |> 
    ungroup() |> 
    rename(category = r_tenure_status) |> 
    mutate(indicator = "Typ bydlení")
) |> 
  ggplot(aes(x = category, y = pct_under_arop, fill = r_country)) + 
  geom_bar(stat = "identity", position = "dodge") + 
  facet_wrap(indicator~., scales = "free") + 
  coord_flip()

g1 <- typ_domacnosti_data |> 
    ungroup() |> 
    rename(category = typ_domacnosti) |> 
    mutate(indicator = "Typ domácnosti") |> 
    ggplot(aes(x = category, y = pct_under_arop, fill = r_country)) + 
    geom_bar(stat = "identity", position = "dodge") + 
    coord_flip() + 
    labs(x = "", y = "% domácností", fill = "", 
          title = "typ domácnosti") + 
    theme(legend.position = "top") + 
    theme_paq() + 
    scale_fill_manual(values = paleta_kategoricka(2))

g2 <- vzdelani_data |> 
    ungroup() |> 
    rename(category = rr_education) |> 
    mutate(indicator = "Vzdělání") |> 
    ggplot(aes(x = category, y = pct_under_arop, fill = r_country)) + 
    geom_bar(stat = "identity", position = "dodge") + 
    coord_flip() + 
    labs(x = "", y = "% domácností", fill = "", 
          title = "vzdělání") + 
    theme(legend.position = "top") + 
    theme_paq() + 
    theme_paq() + 
    scale_fill_manual(values = paleta_kategoricka(2))

g3 <- bydleni_data |> 
    ungroup() |> 
    rename(category = r_tenure_status) |> 
    mutate(indicator = "Typ bydlení") |> 
    ggplot(aes(x = category, y = pct_under_arop, fill = r_country)) + 
    geom_bar(stat = "identity", position = "dodge") + 
    coord_flip() + 
    labs(x = "", y = "% domácností", fill = "", 
          title = "typ bydlení") + 
    theme(legend.position = "top") + 
    theme_paq() + 
    theme_paq() + 
    scale_fill_manual(values = paleta_kategoricka(2))

g1 + (g2 / g3) + 
  plot_layout(guides = 'collect') & 
  theme(legend.position='bottom')

save_plot(last_plot(), "figs/arop/cr_chudoba_skupiny.png")

Změna od 2018

tar_load(r_silc_2019)

hh_r_silc_2019 <- r_silc_2019 %>% 
  group_by(country, hh_id) %>% 
  mutate(
    n_retired = sum(econ_status == "Retired", na.rm = TRUE), 
    n_employed = sum(econ_status == "Employed", na.rm = TRUE), 
    n_adults = sum(age >= 18), 
    n_old_age = sum(age >= 65),
    income_disposable = if_else(income_disposable < 0, 0, income_disposable),  
    income_disposable_eqi = if_else(income_disposable_eqi < 0, 0, income_disposable_eqi)
  ) %>% 
  slice(1) %>% 
  ungroup() %>% 
  mutate(across(where(is.character), ~haven::as_factor(.x))) %>% 
  # filter out EU countries only
  filter(!country %in% c("NO", "RS", "CH")) %>% 
  mutate(country = fct_case_when(
    country == "AT" ~ "Austria",
    country == "BE" ~ "Belgium",
    country == "BG" ~ "Bulgaria",
    country == "CY" ~ "Cyprus",
    country == "CZ" ~ "Czechia",
    country == "DE" ~ "Germany",
    country == "DK" ~ "Denmark",
    country == "EE" ~ "Estonia",
    country == "EL" ~ "Greece",
    country == "ES" ~ "Spain",
    country == "FI" ~ "Finland",
    country == "FR" ~ "France",
    country == "HR" ~ "Croatia",
    country == "HU" ~ "Hungary",
    country == "IE" ~ "Ireland", 
    country == "IT" ~ "Italy",
    country == "LT" ~ "Lithuania",
    country == "LU" ~ "Luxembourg",
    country == "LV" ~ "Latvia",
    country == "MT" ~ "Malta",
    country == "NL" ~ "Netherlands",
    country == "PL" ~ "Poland", 
    country == "PT" ~ "Portugal", 
    country == "RO" ~ "Romania",
    country == "SE" ~ "Sweden",
    country == "SI" ~ "Slovenia",
    country == "SK" ~ "Slovakia"
  )) %>% 
  mutate(
    hh_retired = fct_case_when(
      n_retired == n_persons ~ "Plně důchodcovská domácnost", 
      n_retired > 0 ~ "Domácnost s důchodcem",
      n_retired == 0 ~ "Domácnost bez důchodců"
    ), 
    hh_old = fct_case_when(
      n_old_age == n_persons ~ "Všichni 65+",
      n_old_age > 0 ~ "Alespoň jeden 65+",
      n_old_age == 0 ~ "Bez 65+"
    ),
    typ_domacnosti = fct_case_when(
      n_adults == 2 & n_children > 0 ~ "Úplná domácnost s dětmi",
      n_adults == 1 & n_children > 0 ~ "Samoživitel/ka s dětmi",
      n_adults == 2 & hh_retired == "Plně důchodcovská domácnost" ~ "Dvojice seniorů",
      n_adults == 1 & hh_retired == "Plně důchodcovská domácnost" ~ "Samostatně žijící senior",
      TRUE ~ "Ostatní"
    )
  )

exchange_rates <- read_excel("data/exchange_rates.xlsx", sheet = 3, skip = 8) %>% 
  select(currency = TIME, exchange_rate_2018 = `2018`) %>% 
  filter(!is.na(currency)) %>% 
  mutate(country = case_when(
    currency == "Bulgarian lev" ~ "Bulgaria",
    currency == "Czech koruna" ~ "Czechia",
    currency == "Danish krone" ~ "Denmark",
    currency == "Hungarian forint" ~ "Hungary",
    currency == "Polish zloty" ~ "Poland",
    currency == "Romanian leu" ~ "Romania",
    currency == "Swedish krona" ~ "Sweden"
  )) %>% 
  filter(!is.na(country)) %>% 
  mutate(exchange_rate_2018 = as.numeric(exchange_rate_2018))

ppp_data <- read_excel("data/power_purchasing_parity_2decimals.xlsx") %>% 
  select(country = Country, ppp_2018 = `2018`)

ppp_adjusted <- left_join(ppp_data, exchange_rates, by = "country") %>% 
  mutate(ppp_2018_adjusted = if_else(
    !is.na(exchange_rate_2018), 
    ppp_2018 / exchange_rate_2018,
    ppp_2018
  )) %>% 
  select(country, ppp_2018_adjusted) 

hh_r_silc_2019_ppp <- left_join(hh_r_silc_2019, ppp_adjusted, by = "country") %>% 
  mutate(
    income_disposable_eqi_ppp = income_disposable_eqi / ppp_2018_adjusted
  )

EU_MEDIAN_PPP_2018 <- wtd.quantile(hh_r_silc_2019_ppp$income_disposable_eqi_ppp,
                              hh_r_silc_2019_ppp$hh_cross_weight, 0.5)  
EU_MEDIAN_60PCT_2018 <- EU_MEDIAN_PPP_2018 * 0.6

hh_r_silc_2019_arop <- hh_r_silc_2019_ppp %>% 
  mutate(under_arop = income_disposable_eqi_ppp < EU_MEDIAN_60PCT_2018)

# hh_r_silc_2019_arop %>% 
#   group_by(country) %>% 
#   summarise(pct_under_arop = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE) * 100) %>% 
#   arrange(pct_under_arop) %>% 
#   knitr::kable(., digits = 2, col.names = c("Country", "% under EU AROP (2018)"))

full_join(
  hh_r_silc_2019_arop %>% 
  group_by(country) %>% 
  summarise(pct_under_arop_2018 = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE)
            * 100), 
  hh_r_silc_2023_arop %>% 
  group_by(country) %>% 
  summarise(pct_under_arop_2022 = wtd.mean(under_arop, hh_cross_weight, na.rm = TRUE)
            * 100), 
  by = "country"
) %>% 
  mutate(diff = pct_under_arop_2022 - pct_under_arop_2018) %>% 
  knitr::kable(., digits = 2, col.names = c("Country", "% under AROP (2018)", 
                                            "% under AROP (2022)", 
                                            "Difference 2022-2018"))

Country	% under AROP (2018)	% under AROP (2022)	Difference 2022-2018
Austria	7.19	6.43	-0.76
Belgium	6.13	3.96	-2.16
Bulgaria	66.41	59.87	-6.54
Croatia	47.60	42.35	-5.25
Cyprus	13.07	13.87	0.80
Czechia	26.42	21.68	-4.74
Denmark	7.05	7.45	0.40
Estonia	37.84	39.24	1.40
Finland	8.47	10.35	1.88
France	7.30	11.14	3.84
Germany	10.96	10.84	-0.13
Greece	50.86	48.06	-2.80
Hungary	62.12	55.85	-6.27
Ireland	5.11	4.73	-0.38
Italy	19.70	17.92	-1.78
Latvia	49.71	46.01	-3.70
Lithuania	49.29	41.26	-8.02
Luxembourg	5.65	3.12	-2.54
Malta	17.00	17.39	0.39
Netherlands	7.38	7.49	0.11
Poland	40.59	26.87	-13.72
Portugal	38.91	37.70	-1.22
Romania	72.69	51.73	-20.96
Slovakia	50.07	51.33	1.25
Slovenia	17.95	14.79	-3.16
Spain	23.06	20.14	-2.92
Sweden	13.06	15.21	2.14

Souvislost mezi AROP a materiální deprivací

Evropská hranice AROP

hh_r_silc_2023_national_arop %>% 
  group_by(r_country, under_arop, severe_material_social_deprivation) %>% 
  mutate(severe_material_social_deprivation = as_factor(severe_material_social_deprivation), 
         under_arop = factor(under_arop, levels = c(TRUE, FALSE), 
                             labels = c("Pod EU hranicí", 
                                        "Nad EU hranicí"))) %>% 
  summarise(wtd_n = sum(hh_cross_weight)) %>% 
  group_by(r_country, under_arop) %>% 
  mutate(pct = wtd_n / sum(wtd_n)) %>% 
  ungroup %>% 
  ggplot(aes(x = under_arop, y = pct, fill = severe_material_social_deprivation)) + 
  geom_bar(stat = "identity") + 
  coord_flip() +
  scale_fill_manual(values = paleta_kategoricka(2, na_colour = TRUE)) + 
  scale_y_continuous(labels = scales::label_percent()) + 
  facet_wrap(vars(r_country)) + 
  theme_paq() + 
  labs(x = "", y = "")

hh_r_silc_2023_national_arop %>% 
  group_by(country, under_arop, severe_material_social_deprivation) %>% 
  mutate(severe_material_social_deprivation = as_factor(severe_material_social_deprivation), 
         under_arop = factor(under_arop, levels = c(TRUE, FALSE), 
                             labels = c("Pod EU hranicí", 
                                        "Nad EU hranicí"))) %>% 
  summarise(wtd_n = sum(hh_cross_weight)) %>% 
  group_by(country, under_arop) %>% 
  mutate(pct = wtd_n / sum(wtd_n)) %>% 
  ungroup %>% 
  ggplot(aes(x = under_arop, y = pct, fill = severe_material_social_deprivation)) + 
  geom_bar(stat = "identity") + 
  coord_flip() +
  scale_fill_manual(values = paleta_kategoricka(2, na_colour = TRUE)) + 
  scale_y_continuous(labels = scales::label_percent()) + 
  facet_wrap(vars(country), ncol = 4) + 
  theme_paq() + 
  labs(x = "", y = "")

hh_r_silc_2023_national_arop %>% 
  mutate(under_arop = factor(under_arop, 
                                      levels = c(FALSE, TRUE), 
                                      labels = c(
                                        "Nad EU hranicí ohrožení chudobou",
                                        "Pod EU hranicí ohrožení chudobou"))) %>% 
  group_by(r_country, sum_deprived_items, under_arop) %>% 
  summarise(wtd_n = sum(hh_cross_weight)) %>% 
  group_by(r_country, sum_deprived_items) %>% 
  mutate(pct = wtd_n / sum(wtd_n)) %>% 
  ungroup %>% 
  ggplot(aes(x = sum_deprived_items, y = pct, fill = under_arop)) + 
  geom_bar(stat = "identity") + 
  coord_flip() +
  scale_fill_manual(values = paleta_kategoricka(2, na_colour = TRUE)) + 
  scale_y_continuous(labels = scales::label_percent()) + 
  facet_wrap(vars(r_country)) + 
  theme_paq() + 
  labs(y = "", x = "Počet položek materiální a sociální deprivace") + 
  guides(fill = guide_legend(reverse = TRUE))

hh_r_silc_2023_national_arop %>% 
  mutate(under_arop = factor(under_arop, 
                                      levels = c(FALSE, TRUE), 
                                      labels = c(
                                        "Nad EU hranicí ohrožení chudobou",
                                        "Pod EU hranicí ohrožení chudobou"))) %>% 
  group_by(country, sum_deprived_items, under_arop) %>% 
  summarise(wtd_n = sum(hh_cross_weight)) %>% 
  group_by(country, sum_deprived_items) %>% 
  mutate(pct = wtd_n / sum(wtd_n)) %>% 
  ungroup %>% 
  ggplot(aes(x = sum_deprived_items, y = pct, fill = under_arop)) + 
  geom_bar(stat = "identity") + 
  coord_flip() +
  scale_fill_manual(values = paleta_kategoricka(2, na_colour = TRUE)) + 
  scale_y_continuous(labels = scales::label_percent()) + 
  facet_wrap(vars(country), ncol = 4) + 
  theme_paq() + 
  labs(y = "", x = "Počet položek materiální a sociální deprivace") + 
  guides(fill = guide_legend(reverse = TRUE))

Národní hranice AROP

hh_r_silc_2023_national_arop %>% 
  group_by(r_country, under_national_arop, severe_material_social_deprivation) %>% 
  mutate(severe_material_social_deprivation = as_factor(severe_material_social_deprivation), 
         under_national_arop = factor(under_national_arop, levels = c(TRUE, FALSE), 
                             labels = c("Pod národní hranicí", 
                                        "Nad národní hranicí"))) %>% 
  summarise(wtd_n = sum(hh_cross_weight)) %>% 
  group_by(r_country, under_national_arop) %>% 
  mutate(pct = wtd_n / sum(wtd_n)) %>% 
  ungroup %>% 
  ggplot(aes(x = under_national_arop, y = pct, fill = severe_material_social_deprivation)) + 
  geom_bar(stat = "identity") + 
  coord_flip() +
  scale_fill_manual(values = paleta_kategoricka(2, na_colour = TRUE)) + 
  scale_y_continuous(labels = scales::label_percent()) + 
  facet_wrap(vars(r_country)) + 
  theme_paq()

hh_r_silc_2023_national_arop %>% 
  group_by(country, under_national_arop, severe_material_social_deprivation) %>% 
  mutate(severe_material_social_deprivation = as_factor(severe_material_social_deprivation), 
         under_national_arop = factor(under_national_arop, levels = c(TRUE, FALSE), 
                             labels = c("Pod národní hranicí", 
                                        "Nad národní hranicí"))) %>% 
  summarise(wtd_n = sum(hh_cross_weight)) %>% 
  group_by(country, under_national_arop) %>% 
  mutate(pct = wtd_n / sum(wtd_n)) %>% 
  ungroup %>% 
  ggplot(aes(x = under_national_arop, y = pct, fill = severe_material_social_deprivation)) + 
  geom_bar(stat = "identity") + 
  coord_flip() +
  scale_fill_manual(values = paleta_kategoricka(2, na_colour = TRUE)) + 
  scale_y_continuous(labels = scales::label_percent()) + 
  facet_wrap(vars(country), ncol = 4) + 
  theme_paq()

hh_r_silc_2023_national_arop %>% 
  mutate(under_national_arop = factor(under_national_arop, 
                                      levels = c(FALSE, TRUE), 
                                      labels = c(
                                        "Nad národní hranicí ohrožení chudobou",
                                        "Pod národní hranicí ohrožení chudobou"))) %>% 
  group_by(r_country, sum_deprived_items, under_national_arop) %>% 
  summarise(wtd_n = sum(hh_cross_weight)) %>% 
  group_by(r_country, sum_deprived_items) %>% 
  mutate(pct = wtd_n / sum(wtd_n)) %>% 
  ungroup %>% 
  ggplot(aes(x = sum_deprived_items, y = pct, fill = under_national_arop)) + 
  geom_bar(stat = "identity") + 
  coord_flip() +
  scale_fill_manual(values = paleta_kategoricka(2, na_colour = TRUE)) + 
  scale_y_continuous(labels = scales::label_percent()) + 
  facet_wrap(vars(r_country)) + 
  theme_paq() + 
  labs(y = "", x = "Počet položek materiální a sociální deprivace") + 
  guides(fill = guide_legend(reverse = TRUE))

hh_r_silc_2023_national_arop %>% 
  mutate(under_national_arop = factor(under_national_arop, 
                                      levels = c(FALSE, TRUE), 
                                      labels = c(
                                        "Nad národní hranicí ohrožení chudobou",
                                        "Pod národní hranicí ohrožení chudobou"))) %>% 
  group_by(country, sum_deprived_items, under_national_arop) %>% 
  summarise(wtd_n = sum(hh_cross_weight)) %>% 
  group_by(country, sum_deprived_items) %>% 
  mutate(pct = wtd_n / sum(wtd_n)) %>% 
  ungroup %>% 
  ggplot(aes(x = sum_deprived_items, y = pct, fill = under_national_arop)) + 
  geom_bar(stat = "identity") + 
  coord_flip() +
  scale_fill_manual(values = paleta_kategoricka(2, na_colour = TRUE)) + 
  scale_y_continuous(labels = scales::label_percent()) + 
  facet_wrap(vars(country), ncol = 4) + 
  theme_paq() + 
  labs(y = "", x = "Počet položek materiální a sociální deprivace") + 
  guides(fill = guide_legend(reverse = TRUE))

Korelace mezi podílem mediánového příjmu a materiální deprivací

Celá EU

recode_term <- function(x){
  fct_case_when(
    x == "under_eu_arop" ~ "Under EU AROP",
    x == "under_eu_poverty" ~ "Under EU poverty line (50% median)",
    x == "under_eu_70_boundary" ~ "Under EU 70% median",
    x == "under_national_arop" ~ "Under national AROP",
    x == "under_national_poverty" ~ "Under national poverty line (50% median)",
    x == "under_national_70_boundary" ~ "Under national 70% median",
    x == "severe_material_social_deprivation" ~ "Severe material and social deprivation",
    x == "sum_deprived_items" ~ "Number of deprived items"
  )
}

hh_r_silc_2023_national_arop %>% 
  select(under_eu_arop = under_arop, 
         under_eu_poverty, 
         under_eu_70_boundary,
         under_national_poverty,
         under_national_arop, 
         under_national_70_boundary = under_70_boundary,
         severe_material_social_deprivation,
         sum_deprived_items) %>% 
  mutate(across(everything(), as.numeric)) %>% 
  correlate(use = "pairwise.complete.obs", method = "pearson") %>% 
  select(term, 
         `Severe material and social deprivation` = severe_material_social_deprivation, 
         `Number of deprived items` = sum_deprived_items) %>% 
  mutate(term = recode_term(term)) %>% 
  arrange(term) %>% 
  filter(!term %in% c("Severe material and social deprivation",
                     "Number of deprived items")) %>% 
  gt() %>% 
  fmt_number(decimals = 3) %>% 
  tab_style(
    style = list(cell_fill(color = "red")), 
    locations = cells_body(
      column = `Number of deprived items`, 
      rows = `Number of deprived items` == max(`Number of deprived items`, na.rm = TRUE)
    )
  ) %>% 
  tab_style(
    style = list(cell_fill(color = "red")), 
    locations = cells_body(
      column = `Severe material and social deprivation`, 
      rows = `Severe material and social deprivation` == max(`Severe material and social deprivation`, na.rm = TRUE)
    )
  )

term	Severe material and social deprivation	Number of deprived items
Under EU AROP	0.224	0.377
Under EU poverty line (50% median)	0.229	0.355
Under EU 70% median	0.218	0.386
Under national AROP	0.221	0.326
Under national poverty line (50% median)	0.200	0.274
Under national 70% median	0.228	0.358

ČR vs zbytek EU

tables <- purrr::map(c("Czechia", "Rest of EU"), function(x) {
  hh_r_silc_2023_national_arop %>% 
    mutate(r_country = if_else(country == "Czechia", "Czechia", "Rest of EU")) %>% 
    filter(r_country == x) %>% 
    select(r_country, 
         under_eu_arop = under_arop, 
         under_eu_poverty, 
         under_eu_70_boundary,
         under_national_poverty,
         under_national_arop, 
         under_national_70_boundary = under_70_boundary,
         severe_material_social_deprivation,
         sum_deprived_items) %>% 
    mutate(across(where(is.logical) | where(is.factor), as.numeric)) %>% 
    correlate(use = "pairwise.complete.obs", method = "pearson") %>% 
    select(term, 
         `Severe material and social deprivation` = severe_material_social_deprivation, 
         `Number of deprived items` = sum_deprived_items) %>% 
    mutate(term = recode_term(term)) %>% 
    arrange(term) %>% 
    filter(!term %in% c("Severe material and social deprivation",
                     "Number of deprived items")) %>% 
    gt() %>% 
  fmt_number(decimals = 3) %>% 
  tab_style(
    style = list(cell_fill(color = "red")), 
    locations = cells_body(
      column = `Number of deprived items`, 
      rows = `Number of deprived items` == max(`Number of deprived items`, na.rm = TRUE)
    )
  ) %>% 
  tab_style(
    style = list(cell_fill(color = "red")), 
    locations = cells_body(
      column = `Severe material and social deprivation`, 
      rows = `Severe material and social deprivation` == max(`Severe material and social deprivation`, na.rm = TRUE)
    )
  ) %>% 
  tab_header(
    title = x
  )
})

purrr::walk(tables, print)

Czechia
term	Severe material and social deprivation	Number of deprived items
Under EU AROP	0.209	0.382
Under EU poverty line (50% median)	0.223	0.335
Under EU 70% median	0.169	0.378
Under national AROP	0.228	0.334
Under national poverty line (50% median)	0.207	0.255
Under national 70% median	0.212	0.372

Rest of EU
term	Severe material and social deprivation	Number of deprived items
Under EU AROP	0.225	0.377
Under EU poverty line (50% median)	0.229	0.355
Under EU 70% median	0.221	0.387
Under national AROP	0.221	0.325
Under national poverty line (50% median)	0.199	0.274
Under national 70% median	0.229	0.358

Jednotlivé státy

countries <- unique(hh_r_silc_2023_national_arop$country)
tables <- purrr::map(countries, function(x) {
  hh_r_silc_2023_national_arop %>% 
    filter(country == x) %>% 
    select(country, 
         under_eu_arop = under_arop, 
         under_eu_poverty, 
         under_eu_70_boundary,
         under_national_poverty,
         under_national_arop, 
         under_national_70_boundary = under_70_boundary,
         severe_material_social_deprivation,
         sum_deprived_items) %>% 
    mutate(across(where(is.logical) | where(is.factor), as.numeric)) %>% 
    correlate(use = "pairwise.complete.obs", method = "pearson") %>% 
    select(term, 
         `Severe material and social deprivation` = severe_material_social_deprivation, 
         `Number of deprived items` = sum_deprived_items) %>% 
    mutate(term = recode_term(term)) %>% 
    arrange(term) %>% 
    filter(!term %in% c("Severe material and social deprivation",
                     "Number of deprived items")) %>% 
    gt() %>% 
  fmt_number(decimals = 3) %>% 
  tab_style(
    style = list(cell_fill(color = "red")), 
    locations = cells_body(
      column = `Number of deprived items`, 
      rows = `Number of deprived items` == max(`Number of deprived items`, na.rm = TRUE)
    )
  ) %>% 
  tab_style(
    style = list(cell_fill(color = "red")), 
    locations = cells_body(
      column = `Severe material and social deprivation`, 
      rows = `Severe material and social deprivation` == max(`Severe material and social deprivation`, na.rm = TRUE)
    )
  ) %>% 
  tab_header(
    title = x
  )
})

purrr::walk(tables, print)

Austria
term	Severe material and social deprivation	Number of deprived items
Under EU AROP	0.125	0.175
Under EU poverty line (50% median)	0.063	0.101
Under EU 70% median	0.172	0.249
Under national AROP	0.194	0.320
Under national poverty line (50% median)	0.169	0.241
Under national 70% median	0.192	0.358

Belgium
term	Severe material and social deprivation	Number of deprived items
Under EU AROP	0.148	0.172
Under EU poverty line (50% median)	0.085	0.093
Under EU 70% median	0.208	0.282
Under national AROP	0.224	0.301
Under national poverty line (50% median)	0.181	0.213
Under national 70% median	0.261	0.377

Bulgaria
term	Severe material and social deprivation	Number of deprived items
Under EU AROP	0.267	0.423
Under EU poverty line (50% median)	0.287	0.427
Under EU 70% median	0.244	0.402
Under national AROP	0.273	0.322
Under national poverty line (50% median)	0.245	0.264
Under national 70% median	0.299	0.380

Cyprus
term	Severe material and social deprivation	Number of deprived items
Under EU AROP	0.144	0.357
Under EU poverty line (50% median)	0.173	0.296
Under EU 70% median	0.167	0.414
Under national AROP	0.154	0.368
Under national poverty line (50% median)	0.164	0.299
Under national 70% median	0.161	0.409

Czechia
term	Severe material and social deprivation	Number of deprived items
Under EU AROP	0.209	0.382
Under EU poverty line (50% median)	0.223	0.335
Under EU 70% median	0.169	0.378
Under national AROP	0.228	0.334
Under national poverty line (50% median)	0.207	0.255
Under national 70% median	0.212	0.372

Germany
term	Severe material and social deprivation	Number of deprived items
Under EU AROP	0.154	0.234
Under EU poverty line (50% median)	0.114	0.173
Under EU 70% median	0.177	0.274
Under national AROP	0.176	0.272
Under national poverty line (50% median)	0.146	0.221
Under national 70% median	0.202	0.317

Denmark
term	Severe material and social deprivation	Number of deprived items
Under EU AROP	0.111	0.156
Under EU poverty line (50% median)	0.074	0.105
Under EU 70% median	0.155	0.200
Under national AROP	0.153	0.198
Under national poverty line (50% median)	0.111	0.156
Under national 70% median	0.162	0.223

Estonia
term	Severe material and social deprivation	Number of deprived items
Under EU AROP	0.134	0.319
Under EU poverty line (50% median)	0.137	0.316
Under EU 70% median	0.126	0.321
Under national AROP	0.144	0.319
Under national poverty line (50% median)	0.133	0.238
Under national 70% median	0.140	0.324

Greece
term	Severe material and social deprivation	Number of deprived items
Under EU AROP	0.310	0.499
Under EU poverty line (50% median)	0.348	0.498
Under EU 70% median	0.268	0.482
Under national AROP	0.363	0.452
Under national poverty line (50% median)	0.344	0.398
Under national 70% median	0.353	0.474

Spain
term	Severe material and social deprivation	Number of deprived items
Under EU AROP	0.246	0.343
Under EU poverty line (50% median)	0.224	0.300
Under EU 70% median	0.249	0.364
Under national AROP	0.245	0.343
Under national poverty line (50% median)	0.224	0.301
Under national 70% median	0.249	0.365

Finland
term	Severe material and social deprivation	Number of deprived items
Under EU AROP	0.106	0.222
Under EU poverty line (50% median)	0.046	0.131
Under EU 70% median	0.153	0.303
Under national AROP	0.116	0.249
Under national poverty line (50% median)	0.060	0.156
Under national 70% median	0.158	0.317

France
term	Severe material and social deprivation	Number of deprived items
Under EU AROP	0.223	0.309
Under EU poverty line (50% median)	0.160	0.219
Under EU 70% median	0.268	0.384
Under national AROP	0.250	0.358
Under national poverty line (50% median)	0.191	0.264
Under national 70% median	0.273	0.414

Croatia
term	Severe material and social deprivation	Number of deprived items
Under EU AROP	0.200	0.458
Under EU poverty line (50% median)	0.237	0.484
Under EU 70% median	0.174	0.424
Under national AROP	0.279	0.491
Under national poverty line (50% median)	0.292	0.464
Under national 70% median	0.249	0.491

Hungary
term	Severe material and social deprivation	Number of deprived items
Under EU AROP	0.227	0.370
Under EU poverty line (50% median)	0.266	0.405
Under EU 70% median	0.183	0.324
Under national AROP	0.268	0.340
Under national poverty line (50% median)	0.258	0.300
Under national 70% median	0.303	0.406

Ireland
term	Severe material and social deprivation	Number of deprived items
Under EU AROP	0.082	0.137
Under EU poverty line (50% median)	0.044	0.083
Under EU 70% median	0.172	0.255
Under national AROP	0.202	0.311
Under national poverty line (50% median)	0.101	0.173
Under national 70% median	0.210	0.360

Italy
term	Severe material and social deprivation	Number of deprived items
Under EU AROP	0.186	0.272
Under EU poverty line (50% median)	0.170	0.236
Under EU 70% median	0.184	0.288
Under national AROP	0.187	0.278
Under national poverty line (50% median)	0.174	0.246
Under national 70% median	0.184	0.292

Lithuania
term	Severe material and social deprivation	Number of deprived items
Under EU AROP	0.183	0.370
Under EU poverty line (50% median)	0.202	0.363
Under EU 70% median	0.168	0.374
Under national AROP	0.201	0.340
Under national poverty line (50% median)	0.202	0.291
Under national 70% median	0.200	0.359

Luxembourg
term	Severe material and social deprivation	Number of deprived items
Under EU AROP	0.105	0.153
Under EU poverty line (50% median)	0.093	0.114
Under EU 70% median	0.107	0.165
Under national AROP	0.186	0.353
Under national poverty line (50% median)	0.196	0.324
Under national 70% median	0.185	0.364

Latvia
term	Severe material and social deprivation	Number of deprived items
Under EU AROP	0.222	0.405
Under EU poverty line (50% median)	0.236	0.406
Under EU 70% median	0.194	0.387
Under national AROP	0.251	0.379
Under national poverty line (50% median)	0.235	0.325
Under national 70% median	0.256	0.403

Malta
term	Severe material and social deprivation	Number of deprived items
Under EU AROP	0.138	0.200
Under EU poverty line (50% median)	0.132	0.162
Under EU 70% median	0.157	0.236
Under national AROP	0.156	0.217
Under national poverty line (50% median)	0.129	0.179
Under national 70% median	0.159	0.245

Netherlands
term	Severe material and social deprivation	Number of deprived items
Under EU AROP	0.060	0.129
Under EU poverty line (50% median)	0.023	0.085
Under EU 70% median	0.148	0.235
Under national AROP	0.181	0.288
Under national poverty line (50% median)	0.063	0.132
Under national 70% median	0.185	0.341

Poland
term	Severe material and social deprivation	Number of deprived items
Under EU AROP	0.175	0.355
Under EU poverty line (50% median)	0.192	0.336
Under EU 70% median	0.162	0.345
Under national AROP	0.193	0.329
Under national poverty line (50% median)	0.195	0.289
Under national 70% median	0.180	0.350

Portugal
term	Severe material and social deprivation	Number of deprived items
Under EU AROP	0.219	0.416
Under EU poverty line (50% median)	0.236	0.387
Under EU 70% median	0.203	0.422
Under national AROP	0.249	0.365
Under national poverty line (50% median)	0.225	0.299
Under national 70% median	0.235	0.387

Romania
term	Severe material and social deprivation	Number of deprived items
Under EU AROP	0.300	0.425
Under EU poverty line (50% median)	0.310	0.418
Under EU 70% median	0.285	0.427
Under national AROP	0.279	0.351
Under national poverty line (50% median)	0.247	0.316
Under national 70% median	0.312	0.399

Sweden
term	Severe material and social deprivation	Number of deprived items
Under EU AROP	0.137	0.245
Under EU poverty line (50% median)	0.112	0.191
Under EU 70% median	0.156	0.285
Under national AROP	0.152	0.261
Under national poverty line (50% median)	0.118	0.202
Under national 70% median	0.154	0.285

Slovenia
term	Severe material and social deprivation	Number of deprived items
Under EU AROP	0.212	0.369
Under EU poverty line (50% median)	0.174	0.263
Under EU 70% median	0.212	0.419
Under national AROP	0.214	0.372
Under national poverty line (50% median)	0.184	0.271
Under national 70% median	0.210	0.419

Slovakia
term	Severe material and social deprivation	Number of deprived items
Under EU AROP	0.174	0.319
Under EU poverty line (50% median)	0.251	0.387
Under EU 70% median	0.140	0.262
Under national AROP	0.276	0.351
Under national poverty line (50% median)	0.239	0.259
Under national 70% median	0.268	0.367

Gini

GINI:
- vzít ekvivalizované příjmy domácností - verifikovat si, zda nám sedí GINI s veřejnými publikacemi Eurostat
- ✅ definice ekonomicky aktivní populace - srovnat bez GINI jen na nich
- ✅ volnější - vyřadit plně důchodecké domácnosti - srovnání států bez nich
- ✅ tvrdší - vyřadit domácnosti s alespoň 1 důchodeckým příjmem
- udělat 2D mapy států podle:
- ✅ celkový výše příjmů aktivní populace (PPS) x nerovnosti příjmů
- Česko vyjde v kvadrantu malé příjmy, omezené (ale ne nejmenší nerovnosti)
- nice to have, když to bude fungovat:
- lepší popis distribuce toho GINI - jiný ukazatel nerovnosti, zda není daný tím, že GINI hodně reflektuje nerovnost ve středu?
- srovnání s majetkovým GINI
- vývoj GINIs

Gini podle eurostatu: https://ec.europa.eu/eurostat/databrowser/view/ilc_di12/default/table?lang=en

gini_2023 <- hh_r_silc_2023 %>% 
  group_by(country) %>% 
  summarise(
    gini = Gini(income_disposable_eqi, hh_cross_weight, na.rm = TRUE) * 100, 
    gini_neeqi = Gini(income_disposable, hh_cross_weight, na.rm = TRUE) * 100
  )

gini_2023 %>% 
  mutate(country = as.character(country)) %>% 
  arrange(country) %>% 
  select(-gini_neeqi) %>% 
  knitr::kable(., digits = 2)

country	gini
Austria	29.71
Belgium	25.63
Bulgaria	37.82
Croatia	32.43
Cyprus	30.74
Czechia	25.41
Denmark	29.14
Estonia	34.21
Finland	27.82
France	29.25
Germany	30.18
Greece	31.61
Hungary	29.58
Ireland	29.03
Italy	32.33
Latvia	36.23
Lithuania	38.14
Luxembourg	30.66
Malta	34.81
Netherlands	27.34
Poland	28.78
Portugal	35.20
Romania	30.24
Slovakia	20.94
Slovenia	25.49
Spain	31.90
Sweden	31.39

Důchodci podle ekon. statusu

gini_2023_wo_pensioners <- hh_r_silc_2023 %>% 
  filter(!hh_retired %in% c("Plně důchodcovská domácnost", "Domácnost s důchodcem")) %>% 
  group_by(country) %>% 
  summarise(
    gini_no_pensioners = Gini(income_disposable_eqi, hh_cross_weight, 
                              na.rm = TRUE) * 100, 
    gini_no_pensioners_neeqi = Gini(income_disposable, hh_cross_weight, 
                              na.rm = TRUE) * 100, 
  )
  
gini_2023_wo_full_pensioner_hh <- hh_r_silc_2023 %>% 
  filter(hh_retired != "Plně důchodcovská domácnost") %>% 
  group_by(country) %>% 
  summarise(
    gini_no_full_pensioners = Gini(income_disposable_eqi, hh_cross_weight, 
                                   na.rm = TRUE) * 100, 
    gini_no_full_pensioners_neeqi = Gini(income_disposable, hh_cross_weight, 
                                   na.rm = TRUE) * 100, 
  )
  
gini_2023 %>% 
  full_join(gini_2023_wo_pensioners, by = "country") %>% 
  full_join(gini_2023_wo_full_pensioner_hh, by = "country") %>% 
  select(-ends_with("neeqi")) %>% 
  mutate(
    diff_wo_pensioners = gini_no_pensioners - gini, 
    diff_wo_full_pensioners = gini_no_full_pensioners - gini
  ) %>% 
  mutate(across(where(is.numeric), ~round(.x, 2))) %>% 
  rename(`Stát` = country, `Gini` = gini, 
         `Gini bez domácností s důchodcem` = gini_no_pensioners, 
         `Gini bez důchodcovských domácností` = gini_no_full_pensioners, 
         `Rozdíl Gini bez důchodců - populační Gini` = diff_wo_pensioners, 
         `Rozdíl Gini bez důchodcovských domácností - populační Gini` = diff_wo_full_pensioners) %>% 
  datatable(options = list(
    paging =FALSE,
    searching=FALSE,
    pageLength = 50))

Gini z neekvivalizovaného příjmu

gini_2023 %>% 
  full_join(gini_2023_wo_pensioners, by = "country") %>% 
  full_join(gini_2023_wo_full_pensioner_hh, by = "country") %>% 
  select(country, ends_with("neeqi")) %>% 
  mutate(
    diff_wo_pensioners = gini_no_pensioners_neeqi - gini_neeqi, 
    diff_wo_full_pensioners = gini_no_full_pensioners_neeqi - gini_neeqi
  ) %>% 
  mutate(across(where(is.numeric), ~round(.x, 2))) %>% 
  rename(`Stát` = country, `Gini` = gini_neeqi, 
         `Gini bez domácností s důchodcem` = gini_no_pensioners_neeqi, 
         `Gini bez důchodcovských domácností` = gini_no_full_pensioners_neeqi, 
         `Rozdíl Gini bez důchodců - populační Gini` = diff_wo_pensioners, 
         `Rozdíl Gini bez důchodcovských domácností - populační Gini` = diff_wo_full_pensioners) %>% 
  datatable(options = list(
    paging =FALSE,
    searching = FALSE,
    pageLength = -1))

Důchodci podle věku

gini_2023_wo_old <- hh_r_silc_2023 %>% 
  filter(!hh_old %in% c("Všichni 65+", "Alespoň jeden 65+")) %>% 
  group_by(country) %>% 
  summarise(gini_no_pensioners = Gini(income_disposable_eqi, hh_cross_weight, na.rm = TRUE) * 100)
  
gini_2023_wo_full_old_hh <- hh_r_silc_2023 %>% 
  filter(hh_old != "Všichni 65+") %>% 
  group_by(country) %>% 
  summarise(gini_no_full_pensioners = Gini(income_disposable_eqi, hh_cross_weight, na.rm = TRUE) * 100)
  
gini_2023 %>% 
  select(-ends_with("neeqi")) %>% 
  full_join(gini_2023_wo_old, by = "country") %>% 
  full_join(gini_2023_wo_full_old_hh, by = "country") %>% 
  mutate(
    diff_wo_pensioners = gini_no_pensioners - gini, 
    diff_wo_full_pensioners = gini_no_full_pensioners - gini
  ) %>% 
  mutate(across(where(is.numeric), ~round(.x, 2))) %>% 
  rename(`Stát` = country, `Gini` = gini, 
         `Gini bez domácností s důchodcem` = gini_no_pensioners, 
         `Gini bez důchodcovských domácností` = gini_no_full_pensioners, 
         `Rozdíl Gini bez důchodců - populační Gini` = diff_wo_pensioners, 
         `Rozdíl Gini bez důchodcovských domácností - populační Gini` = diff_wo_full_pensioners) %>% 
  datatable(options = list(
    paging =FALSE,
    searching = FALSE,
    pageLength = -1))

data_2d <- hh_r_silc_2023_ppp %>% 
  group_by(country) %>% 
  summarise(median_income_disposable_eqi_ppp = 
              wtd.quantile(income_disposable_eqi_ppp, hh_cross_weight, 0.5)) %>% 
  ungroup %>% 
  left_join(., gini_2023, by = "country")

AVG_INCOME <- mean(data_2d$median_income_disposable_eqi_ppp)
AVG_GINI <- mean(data_2d$gini)

data_2d %>% 
  mutate(
    country = fct_case_when(
      country == "Bulgaria" ~ "Bulharsko",
      country == "Hungary" ~ "Maďarsko",
      country == "Slovakia" ~ "Slovensko",
      country == "Greece" ~ "Řecko",
      country == "Romania" ~ "Rumunsko",
      country == "Croatia" ~ "Chorvatsko",
      country == "Latvia" ~ "Lotyšsko",
      country == "Lithuania" ~ "Litva",
      country == "Portugal" ~ "Portugalsko",
      country == "Estonia" ~ "Estonsko",
      country == "Poland" ~ "Polsko",
      country == "Czechia" ~ "Česko",
      country == "Malta" ~ "Malta",
      country == "Cyprus" ~ "Kypr",
      country == "Spain" ~ "Španělsko",
      country == "Slovenia" ~ "Slovinsko",
      country == "Italy" ~ "Itálie",
      country == "France" ~ "Francie",
      country == "Germany" ~ "Německo",
      country == "Sweden" ~ "Švédsko",
      country == "Denmark" ~ "Dánsko",
      country == "Belgium" ~ "Belgie",
      country == "Netherlands" ~ "Nizozemsko",
      country == "Finland" ~ "Finsko",
      country == "Ireland" ~ "Irsko",
      country == "Austria" ~ "Rakousko",
      country == "Luxembourg" ~ "Lucembursko")) |> 
  ggplot(aes(x = gini, y = median_income_disposable_eqi_ppp)) + 
  geom_hline(yintercept = AVG_INCOME, colour = "gray60") + 
  geom_vline(xintercept = AVG_GINI, colour = "gray60") + 
  geom_point() + 
  geom_text_repel(aes(label = country)) + 
  labs(x = "Gini koeficient", y = "Mediánový ekvivalizovaný příjem domácnosti v PPP") + 
  theme_paq()

save_plot(last_plot(), 
          "figs/arop/gini.png")

bez důchodců

data_2d_wo_old <- hh_r_silc_2023_ppp %>% 
  filter(!hh_old %in% c("Všichni 65+", "Alespoň jeden 65+")) %>% 
  group_by(country) %>% 
  summarise(median_income_disposable_eqi_ppp = 
              wtd.quantile(income_disposable_eqi_ppp, hh_cross_weight, 0.5)) %>% 
  ungroup %>% 
  left_join(., gini_2023_wo_old, by = "country")

AVG_INCOME <- mean(data_2d_wo_old$median_income_disposable_eqi_ppp)
AVG_GINI <- mean(data_2d_wo_old$gini_no_pensioners)

data_2d_wo_old %>% 
  mutate(
    country = fct_case_when(
      country == "Bulgaria" ~ "Bulharsko",
      country == "Hungary" ~ "Maďarsko",
      country == "Slovakia" ~ "Slovensko",
      country == "Greece" ~ "Řecko",
      country == "Romania" ~ "Rumunsko",
      country == "Croatia" ~ "Chorvatsko",
      country == "Latvia" ~ "Lotyšsko",
      country == "Lithuania" ~ "Litva",
      country == "Portugal" ~ "Portugalsko",
      country == "Estonia" ~ "Estonsko",
      country == "Poland" ~ "Polsko",
      country == "Czechia" ~ "Česko",
      country == "Malta" ~ "Malta",
      country == "Cyprus" ~ "Kypr",
      country == "Spain" ~ "Španělsko",
      country == "Slovenia" ~ "Slovinsko",
      country == "Italy" ~ "Itálie",
      country == "France" ~ "Francie",
      country == "Germany" ~ "Německo",
      country == "Sweden" ~ "Švédsko",
      country == "Denmark" ~ "Dánsko",
      country == "Belgium" ~ "Belgie",
      country == "Netherlands" ~ "Nizozemsko",
      country == "Finland" ~ "Finsko",
      country == "Ireland" ~ "Irsko",
      country == "Austria" ~ "Rakousko",
      country == "Luxembourg" ~ "Lucembursko")) |> 
  ggplot(aes(x = gini_no_pensioners, y = median_income_disposable_eqi_ppp)) + 
  geom_hline(yintercept = AVG_INCOME, colour = "gray60") + 
  geom_vline(xintercept = AVG_GINI, colour = "gray60") + 
  geom_point() + 
  geom_text_repel(aes(label = country)) + 
  labs(x = "Gini koeficient", y = "Mediánový ekvivalizovaný příjem domácnosti v PPP") + 
  theme_paq()

save_plot(last_plot(), 
          "figs/arop/gini_bez_duchodcu.png")

# https://rev01ution.red/wp-content/uploads/2024/03/global-wealth-databook-2023-ubs.pdf

gini_property <- tribble(
  ~country, ~gini_property, 
  "Austria", 76.1,
  "Belgium", 59.6,
  "Bulgaria", 70.6, 
  "Croatia", 69.6,
  "Cyprus", 78.4,
  "Czechia", 78.5, 
  "Denmark", 73.6,
  "Estonia", 73.1,
  "Finland", 72.4,
  "France", 70.3,
  "Germany", 77.2,
  "Greece", 68.1,
  "Hungary", 67.7,
  "Ireland", 79.9,
  "Italy", 67.8,
  "Latvia", 80.4,
  "Lithuania", 70.6,
  "Luxembourg", 64.8,
  "Malta", 60.9,
  "Netherlands", 78.8,
  "Poland", 68.4,
  "Portugal", 70.3,
  "Romania", 69.3,
  "Slovakia", 50.8,
  "Slovenia", 64.4,
  "Spain", 68.3,
  "Sweden", 87.4
)

full_join(gini_2023, gini_property, by = "country") |> 
  mutate(country = fct_case_when(
      country == "Bulgaria" ~ "Bulharsko",
      country == "Hungary" ~ "Maďarsko",
      country == "Slovakia" ~ "Slovensko",
      country == "Greece" ~ "Řecko",
      country == "Romania" ~ "Rumunsko",
      country == "Croatia" ~ "Chorvatsko",
      country == "Latvia" ~ "Lotyšsko",
      country == "Lithuania" ~ "Litva",
      country == "Portugal" ~ "Portugalsko",
      country == "Estonia" ~ "Estonsko",
      country == "Poland" ~ "Polsko",
      country == "Czechia" ~ "Česko",
      country == "Malta" ~ "Malta",
      country == "Cyprus" ~ "Kypr",
      country == "Spain" ~ "Španělsko",
      country == "Slovenia" ~ "Slovinsko",
      country == "Italy" ~ "Itálie",
      country == "France" ~ "Francie",
      country == "Germany" ~ "Německo",
      country == "Sweden" ~ "Švédsko",
      country == "Denmark" ~ "Dánsko",
      country == "Belgium" ~ "Belgie",
      country == "Netherlands" ~ "Nizozemsko",
      country == "Finland" ~ "Finsko",
      country == "Ireland" ~ "Irsko",
      country == "Austria" ~ "Rakousko",
      country == "Luxembourg" ~ "Lucembursko"
    )) |> 
  ggplot(aes(x = gini, y = gini_property)) + 
  geom_point() + 
  geom_vline(xintercept = mean(gini_2023$gini), colour = "gray60") +
  geom_hline(yintercept = mean(gini_property$gini_property), colour = "gray60") + 
  geom_text_repel(aes(label = country)) + 
  # geom_smooth(method = "lm") + 
  labs(x = "Gini příjmů", y = "Gini majetku", caption = "Zdroj: EU-SILC 2023 pro gini index příjmů, Global Wealth Databook 2023 pro Gini majetku") + 
  theme_paq()

save_plot(last_plot(), "figs/arop/gini_income_property.png")